在Picture中显示的文字如何旋转90度

Question

于PictureBox/Form 中旋转字形 
 
 
作者: John Clark Craig 　　　整个程式的重点在于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