Option Explicit
 
' benötigte API - Deklaration
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 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 CreateFontIndirect Lib "gdi32" _
  Alias "CreateFontIndirectA" ( _
  lpLogFont As LOGFONT) As Long
 
Private Declare Function MulDiv Lib "kernel32.dll" ( _
  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
 
' Konstanten
Private Const LF_FACESIZE = 32
Private Const DEFAULT_CHARSET = 1
Private Const ANTIALIASED_QUALITY = 4
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const OUT_TT_PRECIS = 4
Private Const VARIABLE_PITCH = 2
Private Const LOGPIXELSY = 90
 
' FONT-Struktur
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
' Text in beliebigem Winkel ausdrucken
' z.B. auf dem Drucker oder auch in eine PictureBox
Public Sub PrintRotatedText(ByRef oPrinter As Object, _
  ByVal nPosX As Long, _
  ByVal nPosY As Long, _
  ByVal sText As String, _
  Optional ByVal nWinkel As Long = 0, _
  Optional ByVal nSize As Variant, _
  Optional ByVal bBold As Variant, _
  Optional ByVal bItalic As Variant, _
  Optional ByVal bUnderline As Variant, _
  Optional ByVal sFontName As Variant)
 
  Dim hdc As Long
  Dim hFontOld As Long
  Dim nRetVal As Long
  Dim hFont As Long
  Dim oFont As LOGFONT
 
  ' falls optionale Parameter nicht angegeben,
  ' Standard-Werte verwenden
  With oPrinter.Font
    If IsMissing(nSize) Then nSize = .Size
    If IsMissing(bBold) Then bBold = .Bold
    If IsMissing(bItalic) Then bItalic = .Italic
    If IsMissing(bUnderline) Then bUnderline = .Underline
    If IsMissing(sFontName) Then sFontName = .Name
  End With
 
  ' Position in Pixel umrechnen
  With oPrinter
    hdc = .hdc
    nPosX = .ScaleX(nPosX, .ScaleMode, vbPixels)
    nPosY = .ScaleY(nPosY, .ScaleMode, vbPixels)
  End With
 
  ' Neues Font-Objekt erstellen
  With oFont
    .lfHeight = -MulDiv(nSize, GetDeviceCaps(hdc, LOGPIXELSY), 72)
    .lfEscapement = CLng(nWinkel * 10)
    .lfWeight = IIf(bBold, FW_BOLD, FW_NORMAL)
    .lfItalic = Abs(bItalic)
    .lfUnderline = Abs(bUnderline)
    .lfCharSet = DEFAULT_CHARSET
    .lfFaceName = sFontName
    .lfOutPrecision = OUT_TT_PRECIS
    .lfQuality = ANTIALIASED_QUALITY
    .lfPitchAndFamily = VARIABLE_PITCH
  End With
  hFont = CreateFontIndirect(oFont)
  hFontOld = SelectObject(hdc, hFont)
 
  ' Text ausgeben
  Call TextOut(hdc, nPosX, nPosY, sText, Len(sText))
 
  ' Ursprüngliche Schrift wiederherstellen
  Call SelectObject(hdc, hFontOld)
 
  ' Objekte zerstören
  Call DeleteObject(hFont)
End Sub
 
 
 
Private Sub cmdNEU_Click()
cmdPRINT.Visible = True
 
End Sub
 
Private Sub cmdPRINT_Click()
cmdPRINT.Visible = False
 
' Text im Winkel von 180° auf Drucker ausgeben
Printer.ScaleMode = vbMillimeters
Printer.Print
PrintRotatedText Printer, 20, 50, txtVName.Text, 180
Printer.EndDoc
End Sub
 
Private Sub Form_Load()
cmdNEU.Visible = False
 
End Sub