'以下于 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
|