RotateText

Public Declare Function CreateFont Lib _
"gdi32" Alias "CreateFontA" (ByVal _
Height As Long, ByVal Width As Long, _
ByVal Escapement As Long, ByVal _
Orientation As Long, ByVal Weight _
As Long, ByVal Italic As Long, ByVal _
Underline As Long, ByVal StrikeOut As _
Long, ByVal CharSet As Long, ByVal _
OutputPrecision As Long, ByVal _
ClipPrecision As Long, ByVal Quality _
As Long, ByVal PitchAndFamily As _
Long, ByVal Face As String) As Long
Public Declare Function SelectObject _
Lib "gdi32" (ByVal hdc As Long, ByVal _
hObject As Long) As Long
Public Declare Function DeleteObject _
Lib "gdi32" (ByVal hObject As Long) As Long
Public Const FW_BOLD = 700
Public Const FW_NORMAL = 400
Public Const ANSI_CHARSET = 0
Public Const OUT_DEFAULT_PRECIS = 0
Public Const CLIP_DEFAULT_PRECIS = 0
Public Const PROOF_QUALITY = 2
Public Const DEFAULT_PITCH = 0
Public Const FF_DONTCARE = 0
Module Code
Paste the following code into a module.
Public Sub dotext(angpict As Object, _
angfont As StdFont, angtext As String, _
angle As Single)
' Parameters:

' angpict: picture box, etc to draw text in

' angfont: Font object with info about font to use

' angtext: text to print

' angle : angle, measured anti-clockwise from horizontal: ----->

Dim newfont As Long
Dim oldfont As Long
Dim angweight As Long
If angfont.Bold = True Then
angweight = FW_BOLD
Else
angweight = FW_NORMAL
End If
newfont = CreateFont(angfont.Size * 2, _
0, angle * 10, 0, angweight, _
angfont.Italic, angfont.Underline, _
angfont.Strikethrough, ANSI_CHARSET, _
OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, _
PROOF_QUALITY, DEFAULT_PITCH Or FF_DONTCARE, _
angfont.Name)
oldfont = SelectObject(angpict.hdc, newfont)
angpict.CurrentX = 1000
angpict.CurrentY = 1000
angpict.Print angtext
newfont = SelectObject(angpict.hdc, oldfont)
If DeleteObject(newfont) = 0 Then
' could not remove font from GDI heap

End If
End Sub