Create a text special effects in VB
The API function that uses Windows in VB can implement many VB unable to implement extensions. The following program describes how to implement text rotation display by calling the API functions in Windows.
First create an engineering file, then select Project | Add Class Module in the menu Add a new class file and change the Name property of this class to APIFONT, then add the following code in the class's code window: Option Explicit Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As _ Long) As Long Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As _ Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As _ Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function CreateFontIndirect Lib "gdi32" Alias " CreateFontIndirectA "_ (lpLogFont As LOGFONT) As Long Private Declare Function SelectObject Lib" gdi32 "(ByVal hdc As Long, ByVal hObject As _ Long) As Long Private Declare Function TextOut Lib" gdi32 "Alias" TextOutA "(ByVal hdc As Long, _ BYVAL X as long, byval y as stay, byval ncount as string, byval ncount as _ long) As long private declare function setTextAlign LIB "GDI32" (Byval HD c As Long, ByVal wFlags _ As Long) As Long Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Const TA_LEFT = 0 Private Const TA_RIGHT = 2 Private Const TA_CENTER = 6 Private Const TA_TOP = 0 Private const TA_BOTTOM = 8 Private const TA_BASELINE = 24 Private Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte LFFACENAME AS STRING *
50 End Type Private M_LF AS Logfont Private NewFont As Long Private ORGFONT AS Long Public Sub Charplace (o As Object, Txt $, x, y) DIM THROW AS Long Dim Hregion As Long Dim R as Rect R.Left = X R.Right = X o.Textwidth (txt $) * 2 r.top = y r.bottom = y otTheight (txt $) * 2 hregion = creterecTrgn (R.LEFT, R.TOP, R.RIGHT, R. Bottom) Throw = SELECTCLIPRGN (O.HDC, HREGION) throw = Textout (O.HDC, X, Y, TXT $, LEN (TXT $)) deleteObject (HREGON) End Sub Public Sub Setalign (O as Object, Top, Baseline , Bottom, Left, Center, Right) Dim Vert As Long Dim Horz As Long If Top = True Then Vert = TA_TOP If BaseLine = True Then Vert = TA_BASELINE If Bottom = True Then Vert = TA_BOTTOM If Left = True Then Horz = TA_LEFT If Center = True Then Horz = TA_CENTER If Right = True Then Horz = TA_RIGHT SetTextAlign o.hdc, Vert Or Horz End Sub Public Sub setcolor (o As Object, cvalue As Long) Dim Throw As Long Throw = SetTextColor (o.hdc, cvalue ) End s ub Public Sub SelectOrg (o As Object) Dim Throw As Long NewFont = SelectObject (o.hdc, OrgFont) Throw = DeleteObject (NewFont) End Sub Public Sub SelectFont (o As Object) NewFont = CreateFontIndirect (m_LF) OrgFont = SelectObject (o .hdc, newfont) End Sub Public Sub Fontout (Text $, O AS Control, XX, YY) DIM Throw As Long Throw = Textout (O.HDC, XX, YY, Text $, LEN (Text $) End Sub Public Property get width () as long width = m_lf.lfwidth end protection m_lf.lfwidth =
W End Property Public Property Get Height () As Long Height = m_LF.lfHeight End Property Public Property Let Height (ByVal vNewValue As Long) m_LF.lfHeight = vNewValue End Property Public Property Get Escapement () As Long Escapement = m_LF.lfEscapement End Property public Property Let Escapement (ByVal vNewValue As Long) m_LF.lfEscapement = vNewValue End Property public Property Get Weight () As Long Weight = m_LF.lfWeight End Property public Property Let Weight (ByVal vNewValue As Long) m_LF.lfWeight = vNewValue End Property public Property Get Italic () As Byte Italic = m_LF.lfItalic End Property Public Property Let Italic (ByVal vNewValue As Byte) m_LF.lfItalic = vNewValue End Property Public Property Get UnderLine () As Byte UnderLine = m_LF.lfUnderline End Property Public Property Let UnderLine (Byval vnewvalue as byte) m_lf.lfunderline = vnewvalue End Property Public Property get strikeout () as byte strikeout = m_lf.lfstrik eOut End Property Public Property Let StrikeOut (ByVal vNewValue As Byte) m_LF.lfStrikeOut = vNewValue End Property Public Property Get FaceName () As String FaceName = m_LF.lfFaceName End Property Public Property Let FaceName (ByVal vNewValue As String) m_LF.lfFaceName = vNewValue End Property Private Sub Class_Initialize () m_LF.lfHeight = 30 m_LF.lfWidth = 10 m_LF.lfEscapement = 0 m_LF.lfWeight = 400 m_LF.lfItalic = 0 m_LF.lfUnderline = 0 m_LF.lfStrikeOut = 0 m_LF.lfOutPrecision = 0 m_LF.lfClipPrecision = 0 m_lf.lfquality = 0 m_lf.lfpitchandfamily = 0 m_lf.lfcharset = 0 m_lf.lffacename =
