Die Community zu .NET und Classic VB.
Menü

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

 von 

Beschreibung 

VB kann Schrift nur horizontal ausgeben. Um in einem Winkel schreiben zu können muss man die API bemühen. In diesem Beispiel wird der Text auf einer Picturebox ausgegeben.

Schwierigkeitsgrad:

Schwierigkeitsgrad 1

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

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.