by Cafer Demiraslan (2 Submissions)
Category: Windows API Call/Explanation
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Tue 9th November 2004
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Font orientation in any degree in a picture box control
VBcoders
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(LF_FACESIZE) As Byte 'THIS WAS DEFINED IN API-CHANGES MY OWN
lfFacename As String * 33
End Type
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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Sub CheckVals()
Command1.Enabled = ((Val(txtDegree.Text) < 360) And Val(txtSize.Text) > 7)
End Sub
Private Sub FontStuff()
On Error GoTo GetOut
Dim F As LOGFONT, hPrevFont As Long, hFont As Long, FontName As String
Dim FONTSIZE As Integer
FONTSIZE = Val(txtSize.Text)
F.lfEscapement = 10 * Val(txtDegree.Text) 'rotation angle, in tenths
FontName = "Arial Black" + Chr$(0) 'null terminated
F.lfFacename = FontName
F.lfHeight = (FONTSIZE * -20) / Screen.TwipsPerPixelY
hFont = CreateFontIndirect(F)
hPrevFont = SelectObject(Picture1.hdc, hFont)
Picture1.CurrentX = Picture1.Width / Screen.TwipsPerPixelX
Picture1.CurrentY = Picture1.Height / 1.1
Picture1.Print "Funny Font"
' Clean up, restore original font
hFont = SelectObject(Picture1.hdc, hPrevFont)
DeleteObject hFont
Exit Sub
GetOut:
Exit Sub
End Sub
Private Sub Command1_Click()
Picture1.Cls
FontStuff
End Sub
Private Sub txtDegree_Change()
If Not IsNumeric(txtDegree.Text) Then txtDegree.Text = "90"
CheckVals
End Sub
Private Sub txtsize_Change()
If Not IsNumeric(txtSize.Text) Then txtSize.Text = "18"
CheckVals
End Sub
