Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0506: Einen Text beliebig drehen

VB 5/6-Tipp 0506: Einen Text beliebig drehen

 von Klaus Langbein

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CreateFontA (CreateFont), DeleteObject, SelectObject, TextOutA (TextOut)

Download: Download des Beispielprojektes [3,12 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Textfeld "Text1"
' Steuerelement: Optionsfeld-Steuerelement "optOrient" (Index von 0 bis 4)
' Steuerelement: Bildfeld-Steuerelement "Picture1"
'
' Autor: K. Langbein Klaus@ActiveVB.de
'
' Beschreibung: VB kann Schrift nur horizontal ausgeben. Um in
' einem Winkel schreiben zu koennen muss man die API bemuehen. Dieses
' Beispiel zeigt, zusaetzlich wie man diese Art Textausgabe auf
' einem Button unterbringt.
'
Option Explicit

Private 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
                 
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

Dim cw As Long
Dim ch As Long
Dim twpp As Long
Private Sub Command1_Click()

    Dim col As Long
    Dim i As Integer
    Randomize
    ' ' Hier wird eine zufaellige Farbe erzeugt
    col = QBColor(Rnd * 15)
    
    Picture1.ForeColor = col
    For i = 0 To 4
        If optOrient(i).Value = True Then
            Call optOrient_Click(i)
            Exit Sub
        End If
    Next i
    
    
End Sub

Sub text_rotate(hdc As Long, ByVal x As Long, ByVal y As Long, _
                ByVal fontname$, ByVal FSize As Long, _
                ByVal bold As Long, ByVal ital As Long, _
                ByVal alph As Long, ByVal text$)
    
    ' Achtung Scalemode sollte auf 3 = Pixel stehen
    
    Dim hfont As Long
    Dim fontold As Long
    Dim i As Long

    If text$ = "" Then
        Exit Sub
    End If

    If bold <> 0 Then
        If alph = 0 Then
            bold = 1400
        Else
            bold = 700
        End If
        
    Else
        bold = 400
    End If

    FSize = FSize * 1.55
    
    ' Neues Fonthandle erstellen
    hfont = CreateFont(FSize, 0, alph, 0, bold, ital, _
                       0, 0, 1, 4, &H10, 2, 4, fontname$)
                       
    ' Fonthandle auswaehlen
    fontold = SelectObject(hdc, hfont)
    
    ' Text ausgeben
    i = TextOut(hdc, x, y, text$, Len(text$))
    
    ' Wiederauswaehlen der alten Schrift
    i = SelectObject(hdc, fontold)
    
    ' DeleteObject ist sehr wichtig, weil man sonst den
    ' Speicher mit Objekten vollmacht
    i = DeleteObject(hfont)
    

End Sub

Private Sub Form_Load()
    twpp = Screen.TwipsPerPixelX
    optOrient(1).Value = True
End Sub


Private Sub optOrient_Click(Index As Integer)

    Dim alph As Long
    Dim text$
    Dim wi, hei, x, y
    Picture1.Cls
   
    Picture1.fontname = Text1.fontname
    Picture1.FontSize = Text1.FontSize
    Picture1.FontBold = Text1.FontBold
    Picture1.BackColor = Form1.BackColor
    
    ' Winkel werden in zehntel Grad angegeben
    alph = Val(optOrient(Index).Caption) * 10
    text$ = Text1.text
    Select Case alph
    
    Case 0
        alph = 0
        wi = Picture1.TextWidth(text$)
        hei = Picture1.TextHeight(text$)
        Picture1.Width = twpp * (wi * 1.05)
        Picture1.Height = twpp * (hei * 1.1)
        x = 0
        y = 0
        
        
     Case 450
        hei = Picture1.TextHeight(text$)
        wi = Picture1.TextWidth(text$)
        Picture1.Width = twpp * (wi * 1)
        Picture1.Height = Picture1.Width
        x = 0
        y = wi / Sqr(2) + 6
        
        
    Case 900
        wi = Picture1.TextHeight(text$)
        hei = Picture1.TextWidth(text$)
        Picture1.Width = twpp * (wi * 1.2)
        Picture1.Height = twpp * (hei * 1.2)
        x = 0
        y = Picture1.ScaleHeight
        
        
    Case 1800
        wi = Picture1.TextWidth(text$)
        hei = Picture1.TextHeight(text$)
        Picture1.Width = twpp * (wi * 1.2)
        Picture1.Height = twpp * (hei * 1.1)
        x = Picture1.ScaleWidth - 1
        y = hei
       
        
    Case 2700
        alph = 2700
        wi = Picture1.TextHeight(text$)
        hei = Picture1.TextWidth(text$)
        Picture1.Width = twpp * (wi * 1.1)
        Picture1.Height = twpp * (hei * 1.2)
        x = wi
        y = 1
        
        
    Case Else
    
    End Select
    
    Call text_rotate(Picture1.hdc, x, y, Picture1.fontname, _
                    Picture1.FontSize, Picture1.FontBold, _
                    0, alph, text$)
                    
    
    
End Sub


'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Project1.vbp --------------