Const LF_FACESIZE = 32
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 As String * LF_FACESIZE End Type
Private Declare Function SetGraphicsMode Lib "gdi32" (ByVal hdc As Long, _ ByVal iMode As Long) As Long Private Declare Function MulDiv Lib "Kernel32" (ByVal nNumber As Long, _ ByVal nNumerator As Long, ByVal nDenominator As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, _ ByVal nIndex As Long) As Long 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 Declare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" (dest As _ Any, Source As Any, ByVal bytes As Long)
Sub PrintRotatedText(PB As Object, ByVal Text As String, _ Optional ByVal Angle As Integer = -900, Optional x As Variant, _ Optional y As Variant)
Dim hfont As Long, holdfont As Long Dim Font As LOGFONT Const GM_ADVANCED = 2 Const LOGPIXELSY = 90 SetGraphicsMode PB.hdc, GM_ADVANCED Font.lfHeight = -MulDiv(PB.FontSize, GetDeviceCaps(PB.hdc, LOGPIXELSY), 72) Font.lfWidth = 0 Font.lfEscapement = Angle Font.lfOrientation = Angle Font.lfWeight = IIf(PB.FontBold, 700, 400) Font.lfItalic = IIf(PB.FontItalic, 1, 0) Font.lfUnderline = IIf(PB.FontUnderline, 1, 0) Font.lfStrikeOut = IIf(PB.FontStrikethru, 1, 0) Font.lfCharSet = 0 Font.lfOutPrecision = 0 Font.lfClipPrecision = 0 Font.lfQuality = 2 Font.lfPitchAndFamily = 33 Font.lfFaceName = PB.FontName & vbNullChar hfont = CreateFontIndirect(Font) holdfont = SelectObject(PB.hdc, hfont) If Not IsMissing(x) Then PB.CurrentX = x If Not IsMissing(y) Then PB.CurrentY = y PB.Print Text SelectObject PB.hdc, holdfont DeleteObject hfont End Sub |