|
|
Title | Make a text-shaped form with outlined text |
Keywords | CreateFont, SetWindowRgn, region, text-shaped form, shaped form, outlined text |
Categories | Graphics |
|
|
Use the CreateFont API function to make the desired font. Be sure to use a TrueType font. The CustomFont function
make this a little easier.
|
|
' Make a customized font and return its handle.
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 ' Needed for tilted fonts.
CustomFont = CreateFont( _
hgt, wid, escapement, orientation, wgt, _
is_italic, is_underscored, is_striken_out, _
0, 0, CLIP_LH_ANGLES, 0, 0, face)
End Function
|
|
After you create the font, install it in the Form with the SelectObject API function.
Use the GetTextExtentPoint API function to see how big the text is. (This actually includes some empty space
above the text called "internal leading" space. If you needed to know exactly where the text was,
you could use the GetTextMetrics API function to see how big the internal leading space was. See my book
Visual Basic Graphics Programming for more information on font dimensions.)
Make the form big enough to hold the text and center the form on the screen.
Call BeginPath, write the text, and call EndPath to convert the text into a graphic path. Then call SetWindowRgn
to restrict the Form to the region.
Call BeginPath, write the text, and call EndPath to convert the text into a graphic path again. Then call
StrokePath to draw the path. This produces the outlined text. Use a thick DrawWidth so the outline is wide because
half of the outline's thickness will be cropped off by the call to SetWindowRgn.
Use SelectObject to restore the original font and DeleteObject to delete the new font, freeing up its
graphic resources. This is impoertant. If you don't do this, the system may run out of resources.
|
|
' Shape the form.
Private Sub ShapeForm()
Const TEXT1 = "RAD"
Const TEXT2 = "VB"
Const TEXT_HGT = 250
Const TEXT_WID = 100
Const FONT_NAME = "Times New Roman"
Const GAP = -80
Const DRAW_WIDTH = 5
Dim new_font As Long
Dim old_font As Long
Dim hRgn As Long
Dim sz As Size
Dim wid As Single
Dim hgt As Single
Dim pix_wid As Single
Dim pix_hgt As Single
Dim text1_wid As Single
Dim text1_hgt As Single
Dim text2_wid As Single
Dim text2_hgt As Single
Dim x1 As Long
Dim y1 As Long
Dim x2 As Long
Dim y2 As Long
' Prepare the form.
AutoRedraw = True
ScaleMode = vbPixels
BorderStyle = vbBSNone
BackColor = vbBlue
ForeColor = vbBlack
Caption = ""
DrawWidth = DRAW_WIDTH
' ControlBox = False ' Set at design time.
' MinButton = False ' Set at design time.
' MaxButton = False ' Set at design time.
' ShowInTaskbar = False ' Set at design time.
' Create the custom font.
new_font = CustomFont(TEXT_HGT, TEXT_WID, 0, 0, _
FW_BOLD, False, False, False, _
FONT_NAME)
old_font = SelectObject(hdc, new_font)
' Get the size of the first string.
GetTextExtentPoint hdc, TEXT1, Len(TEXT1), sz
text1_wid = sz.cx
text1_hgt = sz.cy
' Get the size of the second string.
GetTextExtentPoint hdc, TEXT2, Len(TEXT2), sz
text2_wid = sz.cx
text2_hgt = sz.cy
' Make the form big enough.
If text1_wid > text2_wid Then
wid = text1_wid
Else
wid = text2_wid
End If
hgt = text1_hgt + text2_hgt + GAP
pix_wid = ScaleX(wid, vbPixels, vbTwips)
pix_hgt = ScaleY(hgt, vbPixels, vbTwips)
Move (Screen.Width - pix_wid) / 2, _
(Screen.Height - pix_hgt) / 2, _
pix_wid, pix_hgt
' Position the text.
x1 = (wid - text1_wid) / 2
y1 = 0
x2 = (wid - text2_wid) / 2
y2 = text1_hgt + GAP
' Make the region.
BeginPath hdc
CurrentX = x1
CurrentY = y1
Print TEXT1
CurrentX = x2
CurrentY = y2
Print TEXT2
EndPath hdc
hRgn = PathToRegion(hdc)
' Constrain the form to the combined region.
SetWindowRgn hWnd, hRgn, False
' Draw the text again with a hollow font.
BeginPath hdc
CurrentX = x1
CurrentY = y1
Print TEXT1
CurrentX = x2
CurrentY = y2
Print TEXT2
EndPath hdc
StrokePath hdc
' Restore the original font.
SelectObject hdc, old_font
' Free font resources (important!)
DeleteObject new_font
End Sub
|
|
|
|
|
|