Покраска текста

[Kovu]

Написал я небольшую программку для покраски градиентом цвета в ббкоде, но иногда некоторые буквы почему то оказываются как бы вне градиента по цвету. Не могли бы вы помочь найти ошибку?

[dr.MIG]

Правильная процедура:

Код: Выделить всё

Private Sub cmdStrt_Click()
Dim R(1) As Long, G(1) As Long, B(1) As Long, deltacol(2) As Long, i As Long, tempstr As String
If Len(txt1.Text) <= 1 Then Exit Sub
    R(0) = &HFF& And clor(0)
    G(0) = (&HFF00& And clor(0)) \ 256
    B(0) = (&HFF0000 And clor(0)) \ 65536
    R(1) = &HFF& And clor(1)
    G(1) = (&HFF00& And clor(1)) \ 256
    B(1) = (&HFF0000 And clor(1)) \ 65536
    deltacol(0) = (R(1) - R(0)) \ Len(txt1.Text)
    deltacol(1) = (G(1) - G(0)) \ Len(txt1.Text)
    deltacol(2) = (B(1) - B(0)) \ Len(txt1.Text)
    For i = 0 To Len(txt1.Text) - 1
        tempstr = tempstr & starttag & Format$(Hex(R(0) + i * deltacol(0)), "00") & Format$(Hex(G(0) + i * deltacol(1)), "00") & Format$(Hex(B(0) + i * deltacol(2)), "00") + "]" & Mid$(txt1.Text, i + 1, 1) & endtag
    Next i
    txt2.Text = tempstr
End Sub

Т.е. в цикле формировать строку не плюсами, а &

[ANDLL]

Т.е. в цикле формировать строку не плюсами, а &

А в этом случае есть разница?

[dr.MIG]

Т.е. в цикле формировать строку не плюсами, а &

А в этом случае есть разница?

Как показывает тестирование программы - есть...

[Kovu]

dr.MIG
Спасибо конечно, не помогло Баг с градиентными переходами есть всё равно. Подправил пока саму процедуру на такую:

Код: Выделить всё

Private Sub cmdStrt_Click()
Dim R(1) As Long, G(1) As Long, B(1) As Long, deltacol(2) As Long, i As Long, tempstr As String, dtemp(2) As String
If Len(txt1.Text) <= 1 Then Exit Sub
    R(0) = &HFF& And clor(0)
    G(0) = (&HFF00& And clor(0)) \ 256
    B(0) = (&HFF0000 And clor(0)) \ 65536
    R(1) = &HFF& And clor(1)
    G(1) = (&HFF00& And clor(1)) \ 256
    B(1) = (&HFF0000 And clor(1)) \ 65536
    deltacol(0) = (R(1) - R(0)) \ (Len(txt1.Text) - 1)
    deltacol(1) = (G(1) - G(0)) \ (Len(txt1.Text) - 1)
    deltacol(2) = (B(1) - B(0)) \ (Len(txt1.Text) - 1)
    For i = 0 To Len(txt1.Text) - 1
        'tempstr = tempstr + starttag + Format$(Hex(R(0) + i * deltacol(0)), "00") + Format$(Hex(G(0) + i * deltacol(1)), "00") + Format$(Hex(B(0) + i * deltacol(2)), "00") + "]" + Mid$(txt1.Text, i + 1, 1) + endtag
        dtemp(0) = Format$(Hex(R(0) + i * deltacol(0)), "00")
        If Len(dtemp(0)) < 2 Then dtemp(0) = "0" + dtemp(0)
        dtemp(1) = Format$(Hex(G(0) + i * deltacol(1)), "00")
        If Len(dtemp(1)) < 2 Then dtemp(1) = "0" + dtemp(1)
        dtemp(2) = Format$(Hex(B(0) + i * deltacol(2)), "00")
        If Len(dtemp(2)) < 2 Then dtemp(2) = "0" + dtemp(2)
        tempstr = tempstr & starttag & dtemp(0) & dtemp(1) & dtemp(2) & "]" & Mid$(txt1.Text, i + 1, 1) & endtag
    Next i
    txt2.Text = tempstr
End Sub


[ANDLL]

Как показывает тестирование программы - есть...

Видимо, все таки нет.

[Хакер]

Работает или нет. Сейчас проверим на форуме!
Вроде бы работает...

Вот новый код формы:

Код: Выделить всё

Const starttag = "[color=#"
Const endtag = "[/color]"

Private Sub cmdStrt_Click()
    txt2.Text = ""
    For i = 1 To Len(txt1.Text)
        txt2 = txt2 + starttag + blendColor(picstrt.BackColor, picend.BackColor, i / Len(txt1.Text)) + "]" + Mid$(txt1.Text, i, 1) + endtag
    Next i
End Sub

Private Sub Form_Load()
picstrt.BackColor = vbBlack
picend.BackColor = vbBlack
txt1.Text = ""
txt2.Text = ""
End Sub

Private Sub picend_Click()
CD1.ShowColor
picend.BackColor = CD1.Color
clor(1) = CD1.Color
End Sub

Private Sub picstrt_Click()
CD1.ShowColor
picstrt.BackColor = CD1.Color
clor(0) = CD1.Color
End Sub

Public Function blendColor(cFrom As Long, cTo As Long, sProgress As Single) As String
Dim sR As Byte, sG As Byte, sB As Byte
Dim dr As Byte, dg As Byte, db As Byte

sR = cFrom And CByte(255)
sG = (cFrom And 65535) \ 256
sB = (cFrom And (CLng(256) * 256 * 256 - 1)) \ 256 \ 256

dr = cTo And CByte(255)
dg = (cTo And 65535) \ 256
db = (cTo And (CLng(256) * 256 * 256 - 1)) \ 256 \ 256

blendColor = hexform( _
sR - ((CInt(sR) - CInt(dr)) * sProgress), _
sG - ((CInt(sG) - CInt(dg)) * sProgress), _
sB - ((CInt(sB) - CInt(db)) * sProgress))


End Function

Public Function hexform(ByVal iRed As Integer, ByVal iGreen As Integer, ByVal iBlue As Integer) As String
hexform = Right("00" + Hex(iRed), 2) + _
          Right("00" + Hex(iGreen), 2) + _
          Right("00" + Hex(iBlue), 2)
End Function


[Kovu]

Хм, вот с этими цветами раньше были глюки
Спасибо огромное, Хакер

[Amed]

Помнится, несколько месяцев назад мы с d3drm еще и вот так развлекались...

Код: Выделить всё

Const startsize = "[size="
Const endsize = "[/size]"

'...

        txt2 = txt2 + startsize + CStr(CInt(8 + Abs(4 * Sin(3.14 / 2 + i / 5)))) + "]" + starttag + blendColor(picstrt.BackColor, picend.BackColor, i / Len(txt1.Text)) + "]" + Mid$(txt1.Text, i, 1) + endtag + endsize

'...