这整个程式的重点在于LOGFONT中 lfEscapement lfOrientation角度的设定，而使这个
Font产生斜角的效果，使用CreateFontinDirect()依LOGFONT产生自订字型，并取得字型
的Handle，使用SelectObject()将该字型指定给hDc，如此在该hDc上所作的文字输出，便
是该字型的结果。如果您比较注意，会发现LOGFONT中lfWidth(平均宽度)没有设，所以会
取内定值，如果您设了，便会改变字体的宽度，本人一直找不到如何由POINT的字体大小
单位，来算出平均宽度的作法，因为我想知道TextBox中某个字的宽度，我的想怯是：
1.GetDc(text1.hWnd)
2.依Text1所设的Font设定LOGFONT，而後产生字型
3.使用GetTextExtentPoint32来取得字的宽度。
不过我失败了，因为LOGTEXT中的lfWidth取内定值(没有设定)，出来的结果不太对(少
一些，我是用Form的TextWidth方法与之比较)，我想是lfWidth没有设好的关系，
後来我找到解决之道了，详见设定Caret的大小与其所在的字元相同
'以下于 ROTATOR.CLS
Option Explicit
'API constants
Private Const LF_FACESIZE = 32
Private Const LOGPIXELSY = 90
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 - 1) As Byte
End Type
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 Declare Function CreateFontIndirect _
Lib "gdi32" Alias "CreateFontIndirectA" ( _
lpLogFont As LOGFONT _
) As Long
Private Declare Function TextOut _
Lib "gdi32" Alias "TextOutA" ( _
ByVal hdc As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal lpString As String, _
ByVal nCount As Long _
) As Long
Private Declare Function GetDeviceCaps _
Lib "gdi32" ( _
ByVal hdc As Long, _
ByVal nIndex As Long _
) As Long
'Module-level private variables
Private mobjDevice As Object
Private mfSX1 As Single
Private mfSY1 As Single
Private mfXRatio As Single
Private mfYRatio As Single
Private lfFont As LOGFONT
Private mnAngle As Integer
'~~~Angle 设定旋转角度
Property Let Angle(nAngle As Integer)
mnAngle = nAngle
End Property
Property Get Angle() As Integer
Angle = mnAngle
End Property
'~~~Label sText为待显示之字串
Public Sub Label(sText As String)
Dim lFont As Long
Dim lOldFont As Long
Dim lRes As Long
Dim byBuf() As Byte
Dim nI As Integer
Dim sFontName As String
'Prepare font name, decoding from Unicode
sFontName = mobjDevice.Font.Name
byBuf = StrConv(sFontName, vbFromUnicode)
For nI = 0 To UBound(byBuf)
lfFont.lfFaceName(nI) = byBuf(nI)
Next nI
'将字形大小由Point转成Pixels
lfFont.lfHeight = mobjDevice.Font.Size * _
GetDeviceCaps(mobjDevice.hdc, LOGPIXELSY) \ 72
'Set Italic or not
If mobjDevice.Font.Italic = True Then
lfFont.lfItalic = 1
Else
lfFont.lfItalic = 0
End If
'Set Underline or not
If mobjDevice.Font.Underline = True Then
lfFont.lfUnderline = 1
Else
lfFont.lfUnderline = 0
End If
'Set Strikethrough or not
If mobjDevice.Font.Strikethrough = True Then
lfFont.lfStrikeOut = 1
Else
lfFont.lfStrikeOut = 0
End If
'Set Bold or not (use font's weight)
lfFont.lfWeight = mobjDevice.Font.Weight
'Set font rotation angle
lfFont.lfEscapement = CLng(mnAngle * 10#)
lfFont.lfOrientation = lfFont.lfEscapement
'Build temporary new font and output the string
lFont = CreateFontIndirect(lfFont)
lOldFont = SelectObject(mobjDevice.hdc, lFont)
'以下这两行cww加入，否则中文有问题
Dim len5 As Long
len5 = LenB(StrConv(sText, vbFromUnicode))
lRes = TextOut(mobjDevice.hdc, XtoP(mobjDevice.CurrentX), _
YtoP(mobjDevice.CurrentY), sText, len5)
lFont = SelectObject(mobjDevice.hdc, lOldFont)
DeleteObject lFont
End Sub
'~~~Device
Property Set Device(objDevice As Object)
Dim fSX2 As Single
Dim fSY2 As Single
Dim fPX2 As Single
Dim fPY2 As Single
Dim nScaleMode As Integer
Set mobjDevice = objDevice
With mobjDevice
'Grab current scaling parameters
nScaleMode = .ScaleMode
mfSX1 = .ScaleLeft
mfSY1 = .ScaleTop
fSX2 = mfSX1 + .ScaleWidth
fSY2 = mfSY1 + .ScaleHeight
'Temporarily set pixels mode
.ScaleMode = vbPixels
'Grab pixel scaling parameters
fPX2 = .ScaleWidth
fPY2 = .ScaleHeight
'Reset user's original scale
If nScaleMode = 0 Then
mobjDevice.Scale (mfSX1, mfSY1)-(fSX2, fSY2)
Else
mobjDevice.ScaleMode = nScaleMode
End If
'Calculate scaling ratios just once
mfXRatio = fPX2 / (fSX2 - mfSX1)
mfYRatio = fPY2 / (fSY2 - mfSY1)
End With
End Property
'Scales X value to pixel location
Private Function XtoP(fX As Single) As Long
XtoP = (fX - mfSX1) * mfXRatio
End Function
'Scales Y value to pixel location
Private Function YtoP(fY As Single) As Long
YtoP = (fY - mfSY1) * mfYRatio
End Function
'以下在Form，并放一个PictureBox
Private rotTest As New Rotastor
Private Sub Picture1_Click()
Dim nA As Integer
'Prepare the font in the picture box
Picture1.Scale (-1, -1)-(1, 1) '改变座标的范围
With Picture1
.CurrentX = 0
.CurrentY = 0
End With
'Connect Rotator object to the picture box
Set rotTest.Device = Picture1
'Label strings at a variety of angles
For nA = 0 To 359 Step 15
rotTest.Angle = nA
rotTest.Label Space(20) & Picture1.Font.Name & Str(nA)
Next nA
End Sub