Startseite / Tipps / VB 5/6-Tipp 0507: Buttonbeschriftung in beliebigem Winkel

VB 5/6-Tipp 0507: Buttonbeschriftung in beliebigem Winkel

 von Klaus Langbein

'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: Optionsfeld-Steuerelement "optOrient" (Index von 0 bis 4)
' Steuerelement: Schaltfläche "Command1"
' 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
        bold = 700    ' so ist das nun mal - fragt nicht warum!
    Else
        bold = 400
    End If

    FSize = FSize * 1.55 ' Keine Ahnung warum man das machen muss
                         ' (wohl ein MS bug)
    
    ' 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()

    ' Die Caption wird in Tag zwischengespeichert
    Command1.Tag = Command1.Caption
    
    ' Die groesse merken wir uns
    cw = Command1.Width
    ch = Command1.Height
    
    ' und das zur Vereinfachung
    twpp = Screen.TwipsPerPixelX
    
End Sub


Private Sub optOrient_Click(Index As Integer)

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


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

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

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

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 4 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

Private Sub DrawRotateText(alph As Integer)


    Command1.Caption = ""
    'Copy the font parameters
    Picture1.fontname = Command1.fontname
    Picture1.FontSize = Command1.FontSize
    Picture1.FontBold = Command1.FontBold
    Picture1.BackColor = Command1.BackColor
    
    'Measure the string
    Dim wi, hei
    wi = Picture1.TextWidth(Command1.Tag) + 3
    hei = Picture1.TextHeight(Command1.Tag) + 3
    
    Dim pi As Double
    pi = 3.1415
    Dim b, d, x
    b = Abs(wi * Cos(alph * pi / 180))
    d = Abs(hei * Sin(alph * pi / 180))
    x = b + d
    Dim a, c, y
    a = Abs(wi * Sin(alph * pi / 180))
    c = Abs(hei * Cos(alph * pi / 180))
    y = a + c
    
    Dim drawStartX
    If alph > 270 Then
        drawStartX = d
    ElseIf alph > 180 Then
        drawStartX = x
    ElseIf alph > 90 Then
        drawStartX = b
    Else
        drawStartX = 0
    End If
    
    Dim drawStartY
    If alph > 270 Then
        drawStartY = 0
    ElseIf alph > 180 Then
        drawStartY = c
    ElseIf alph > 90 Then
        drawStartY = y
    Else
        drawStartY = a
    End If
    
    Picture1.Width = x * twpp
    Picture1.Height = y * twpp
    Picture1.Cls
    Call text_rotate(Picture1.hdc, drawStartX, drawStartY, Picture1.fontname, _
                    Picture1.FontSize, Picture1.FontBold, _
                    0, alph * 10, Command1.Tag)
    Command1.Picture = Picture1.Image
    Command1.Width = x * twpp
    Command1.Height = y * twpp
End Sub

Call text_rotate(Picture1.hdc, x, y, Picture1.fontname, _
                Picture1.FontSize, Picture1.FontBold, _
                0, alph, Command1.Tag)

Picture1.BackColor = Command1.BackColor