Tipp 0511 Text in beliebigem Winkel drehen
Autor/Einsender:
Datum:
  Dinko Hasanbasic
29.08.2006
Entwicklungsumgebung:   VB 6
Leider fehlt in Visual Basic die direkte Möglichkeit, einen Text zu drehen, um beispielsweise ein Diagramm zu beschriften. Aber wozu gibt es denn die API (Application Programming Interface) mit ihren mannigfaltigen Möglichkeiten. Mit der GDI-Funktion CreateFont wird die gewünschte Schrift erzeugt und sie gibt gleichzeitig ein Font-Handle (Fnt_hDC) zurück.
Nun muss nur noch mit SelectObject der Zielkontext festgelegt werden, auf dem die Funktion TextOut die Schrift ausgeben soll. Wichtig ist, dass die alte Schrift gesichert, nach der Zeichenoperation wiederhergestellt, und die neue virtuell erzeugte Schrift wieder gelöscht werden muss. Dies übernimmt die API-Funktion DeleteDC. Als besonderer Effekt kann in diesem Beispiel die gedrehte Schrift auch noch verschoben werden.
Code im Codebereich des Moduls
 
Option Explicit

Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" ( _
      ByVal H As Long, ByVal W As Long, ByVal E As Long, _
      ByVal O As Long, ByVal W As Long, ByVal I As Long, _
      ByVal u As Long, ByVal S As Long, ByVal C As Long, _
      ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, _
      ByVal PAF As Long, ByVal F As String) As Long

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

Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
      ByVal hObject As Long) As Long

Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, _
      ByVal crColor As Long) As Long

Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long

Dim Fnt_hDC As Long
Dim Fnt_Add As Long

Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc _
      As Long, ByVal nIndex As Long) As Long

Public Declare Function MulDiv Lib "kernel32" (ByVal nNumber _
      As Long, ByVal nNumerator As Long, ByVal nDenominator _
      As Long) As Long

Public Const LOGPIXELSY = 90

Sub Text_Make(Groesse As Integer, Grad As Long, Stil_Italic _
      As Long, Stil_Bold As Boolean, Stil_Underline As Long, _
      Font_Name As String, Farbe As Long, Ziel_hDC As Long)

  If Fnt_hDC > 0 Then Text_Delete

  If Stil_Bold = False Then
    Fnt_hDC = CreateFont(Groesse, 0, Grad * 10, 0, 400, _
          Stil_Italic, Stil_Underline, 0, 1, 4, &H10, 2, 4, _
          Font_Name)
  Else
    Fnt_hDC = CreateFont(Groesse, 0, Grad * 10, 0, 700, _
          Stil_Italic, Stil_Underline, 0, 1, 4, &H10, 2, 4, _
          Font_Name)
  End If
  Text_Select Ziel_hDC
  SetTextColor Ziel_hDC, Farbe
End Sub

Sub Text_Select(Ziel As Long)
  Fnt_Add = SelectObject(Ziel, Fnt_hDC)
End Sub

Sub Text_Delete()
  DeleteDC Fnt_hDC
  Fnt_hDC = 0
End Sub

Sub Text_Print(X As Long, Y As Long, sText As String, Ziel As Long)
  TextOut Ziel, X + 4, Y + 4, sText, Len(sText)
  Text_Delete
End Sub
 
Code im Codebereich der Form
 
Option Explicit

Private Declare Function DeleteObject Lib "gdi32" (ByVal _
      hObject As Long) As Long

Private Sub Form_Load()
  Me.Show
  MakeFormTransparent Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Dim Res As Integer

  Me.Hide
  If hCombined > 0 Then
    Res = DeleteObject(hCombined)
  End If
  End
End Sub

Private Sub Command1_MouseMove(Button As Integer, Shift As _
      Integer, X As Single, Y As Single)
  If Button = 1 Then
    MoveObject Me
  End If
End Sub

Private Sub Frame1_MouseMove(Button As Integer, Shift As Integer, _
      X As Single, Y As Single)
  If Button = 1 Then
    MoveObject Me
  End If
End Sub

Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, _
      X As Single, Y As Single)
  If Button = 1 Then
    MoveObject Me
  End If
End Sub
 
Hinweis
Es können nur TrueType-Schriftarten gedreht werden.
Weitere Links zum Thema
Grafiken mit GetDIBits und SetDIBits drehen

Windows-Version
95
98
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (5,1 kB) Downloads bisher: [ 743 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Dienstag, 7. Juni 2011