Для того, чтобы сделать желаемый шрифт,
используется API функция CreateFont. Необходимо
использовать TrueType шрифт. При помощи функции
CustomFont это делается немного проще.
' Создаём шрифт и возвращаем его дескриптор.
Private Function CustomFont(ByVal hgt As Long, ByVal wid As _
Long, ByVal escapement As Long, ByVal orientation As _
Long, ByVal wgt As Long, ByVal is_italic As Long, ByVal _
is_underscored As Long, ByVal is_striken_out As Long, _
ByVal face As String) As Long
Const CLIP_LH_ANGLES = 16 ' Необходимо для наклонных шрифтов.
CustomFont = CreateFont( _
hgt, wid, escapement, orientation, wgt, _
is_italic, is_underscored, is_striken_out, _
0, 0, CLIP_LH_ANGLES, 0, 0, face)
End Function
После того, как шрифт создан, прикрепляем его к
форме или PictureBox, взависимости от того, где мы
будем рисовать API функцией SelectObject.
Далее, для
вывода текста вызывается BeginPath, а затем EndPath для
конвертации текста в графику. Потом вызываем
SetWindowRgn, чтобы обрезать Форму/PictureBox по заданному
региону. Теперь, чтобы Вы не рисовали, будет
рисоваться в в пределах региона. Поэтому просто
рисуем линии, плавно изменяя цвет.
Чтобы восстановить изначальный шрифт,
используется функция SelectObject, а для удаления
нового шрифта - функция DeleteObject, освобождая тем
самым ресурсы. Если этого не сделать, то
произойдёт утечка памяти.
Private Sub ShapePicture()
Const TEXT1 = "FLOWERS"
Dim new_font As Long
Dim old_font As Long
Dim hRgn As Long
Dim Y As Single
Dim g As Single
Dim dg As Single
' Подготавливаем PictureBox.
ScaleMode = vbPixels
Picture1.AutoRedraw = True
Picture1.ScaleMode = vbPixels
Picture1.BorderStyle = vbBSNone
Picture1.BackColor = vbBlue
Picture1.ForeColor = vbBlack
Picture1.DrawWidth = 1
' Делаем большой шрифт.
new_font = CustomFont(250, 65, 0, 0, _
FW_BOLD, False, False, False, _
"Times New Roman")
old_font = SelectObject(Picture1.hdc, new_font)
' Создаём регион.
SelectObject Picture1.hdc, new_font
BeginPath Picture1.hdc
Picture1.CurrentX = (ScaleWidth - _
Picture1.TextWidth(TEXT1)) / 2
Picture1.CurrentY = -40
Picture1.Print TEXT1
EndPath Picture1.hdc
hRgn = PathToRegion(Picture1.hdc)
' Прикрепляем PictureBox к региону.
SetWindowRgn Picture1.hWnd, hRgn, False
' Восстанавливаем изначальный шрифт.
SelectObject hdc, old_font
' Освобождаем ресурсы, занятые шрифтом (важно!)
DeleteObject new_font
' Рисуем линии через PictureBox.
dg = -255 / Picture1.ScaleHeight
g = 255
For Y = 0 To Picture1.ScaleHeight
Picture1.Line (0, Y)-Step(Picture1.ScaleWidth, 0), _
RGB(0, g, 0)
g = g + dg
Next Y
End Sub