Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0752: Vertikalen Text ausgeben

VB 5/6-Tipp 0752: Vertikalen Text ausgeben

 von Klaus Langbein

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [3,78 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 "frmTxtRotate" alias frmTxtRotate.frm  ---
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Schaltfläche "Command1"
Option Explicit

Private Sub Command1_Click()

    Dim x As Double
    Dim y As Double
    Dim Text$
    
    Picture1.Cls
    Picture1.Scale (-5, 1.3)-(5, -1.3)
    Picture1.ForeColor = RGB(150, 150, 150)
    Picture1.Line (-4, 0)-(4, 0)
    Picture1.Line (0, 1)-(0, -1)
    Picture1.ForeColor = 0
    Picture1.Line (-4, 1)-(4, -1), , B
    Picture1.ForeColor = vbBlue
    Picture1.PSet (-4, 0)
    
    ' Picture1.DrawWidth = 2
    For x = -4 To 4 Step 0.01
    
        y = -2 * Sin(x) * Exp(-x ^ 2)
        Picture1.Line -(x, y)
        
    Next x
    
    ' Scalemode zurücksetzen, da ScaleX kein Scalemode 0 beherrscht
    Picture1.ScaleMode = 3
    Picture1.ForeColor = 0
    Picture1.FontName = "Arial"
    Picture1.FontBold = True
    Picture1.FontSize = 10
    Text$ = "Achsbeschriftung Y"
    y = Picture1.ScaleHeight / 2 + Picture1.TextWidth(Text) / 2
    x = 20
    RotatedTextOut Text$, Picture1, x, y, 90
    Picture1.ForeColor = vbYellow
    Picture1.FontSize = 10
    Text$ = " Achsbeschriftung Y andersrum "
    y = Picture1.ScaleHeight / 2 - Picture1.TextWidth(Text) / 2
    x = Picture1.ScaleWidth - 20
    RotatedTextOut Text$, Picture1, x, y, 270, vbBlue
    Me.AutoRedraw = True
    Text$ = "Copyright: K. Langbein, ActiveVb.de 2007"
    x = Picture1.Left + Picture1.Width + 250
    y = Picture1.Top
    RotatedTextOut Text$, Me, x, y, 270
    Picture1.ForeColor = 0
    Text$ = "Achsbeschriftung X"
    Picture1.CurrentX = Picture1.ScaleWidth / 2 - Picture1.TextWidth(Text) / 2
    Picture1.CurrentY = Picture1.ScaleHeight - 30
    Picture1.Print Text$
    
End Sub

Private Sub Form_Load()

    Picture1.Backcolor = &HE0FFFF
    Picture1.AutoRedraw = True
    Picture1.Width = 7000
    Picture1.Height = 4500
    Command1.Caption = "Plot"
    
End Sub

' --- Ende Formular "frmTxtRotate" alias frmTxtRotate.frm  ---
' --------- Anfang Modul "Module1" alias Module1.bas ---------
Option Explicit

Public Function RotatedTextOut(ByVal Text As String, ByRef Dest As Object, _
    ByVal xDest As Double, ByVal yDest As Double, ByVal Angle As Double, _
    Optional ByVal Backcolor As Long = -1 ) As Long
    
    ' Standalone-Funktion zur Ausgabe von gedrehtem Text.
    ' Geeignet, um mal schnell eine vertikale Achsbeschriftung zu
    ' erstellen. Nur für 90°-Schritte geeignet und nicht zeitoptimiert.
    ' Antialiasing wird berücksichtigt. Kommt ohne API und sonstige
    ' Tricks aus.
    ' Autor/Copyright: K. Langbein, ActiveVB.de, 2007
    On Error Goto err1
    
    Dim Frm As Object
    Dim Pic As Object
    Dim sm As Long
    Dim th As Long
    Dim tw As Long
    Dim Col() As Long
    Dim x() As Long
    Dim y() As Long
    Dim bk As Long
    Dim i As Long
    Dim j As Long
    Dim n As Long
    Dim Alpha As Double
    Dim SinA As Double
    Dim CosA As Double
    Dim Xi As Double
    Dim Yi As Double
    Dim dw As Long
    
    Const RPD = 1.74532925199433E-02  ' Radian pro Grad (=Pi/180)
    sm = Dest.ScaleMode
    dw = Dest.DrawWidth
    Dest.DrawWidth = 1
    Dest.ScaleMode = 3
    
    ' Es wird eine Form als Container für die temporäre Picturebox benötigt
    If TypeOf Dest Is Form Then
    
        Set Frm = Dest
        
    Else
    
        Set Frm = Dest.Parent
        
    End If
    
    ' Temporäre Picturebox erzeugen und Eigenschaften einstellen
    Set Pic = Frm.Controls.Add("VB.Picturebox", "Pic", Frm)
    Set Pic.Font = Dest.Font
    
    Pic.AutoRedraw = True
    Pic.BorderStyle = 0
    Pic.Appearance = 0
    Pic.ScaleMode = 3
    Pic.ForeColor = Dest.ForeColor
    
    ' Größe der Picturebox anpassen
    tw = Pic.TextWidth(Text)
    th = Pic.TextHeight(Text)
    Pic.Width = Dest.ScaleX(tw + 1, 3, Frm.ScaleMode)
    Pic.Height = Dest.ScaleY(th + 1, 3, Frm.ScaleMode)
    n = Pic.ScaleWidth * Pic.ScaleHeight + 1 ' Anzahl der Pixel + Reserve
    ReDim x(n)
    ReDim y(n)
    ReDim Col(n)
    
    ' Pic.Visible = True     ' nur zur Kontrolle einschalten
    If Backcolor = -1 Then  ' Falls transparenter Text ausgegeben werden soll,
    
        bk = Dest.Backcolor ' übernehmen wir die Hintergundfarbe des Ziel-DC.
        
    Else
    
        bk = Backcolor      ' Ansonsten die gewünschte Farbe,
        
    End If
    
    Pic.Backcolor = bk
    
    ' Pic.Cls
    ' Textausgabe in temporärer Picturebox
    Pic.Print Text
    
    ' Farb- und Ortsinformation speichern
    n = 0
    
    For j = 0 To Pic.ScaleHeight - 1
        For i = 0 To Pic.ScaleWidth - 1
        
            n = n + 1
            x(n) = i
            y(n) = j
            Col(n) = Pic.Point(i, j)
            
        Next i
    Next j
    
    ' Winkel einstellen:         ' Übergabe von +90° bedeutet Drehung
    Alpha = -Angle * RPD         ' gegen Uhrzeigersinn
    SinA = Sin(Alpha)            ' Sinus und Kosinus Vorberechnen
    CosA = Cos(Alpha)
    
    ' Koordinatentransformation (Rotation)
    If Alpha <> 0 Then ' Drehung wird nur benötigt, wenn Alpha<>0
    
        For i = 1 To n
        
            Xi = x(i)
            Yi = y(i)
            x(i) = CLng(CosA * Xi - SinA * Yi)
            y(i) = CLng(SinA * Xi + CosA * Yi)
            
        Next i
        
    End If
    
    ' Ausgabeort in Pixeln Berechnen
    Xi = CLng(Dest.ScaleX(xDest, sm, 3))
    Yi = CLng(Dest.ScaleY(yDest, sm, 3))
    
    ' Ausgabe der gedrehten Pixel
    If Backcolor <> -1 Then
    
        For i = 1 To n
        
            Dest.PSet (Xi + x(i), Yi + y(i)), Col(i)
            
        Next i
        
    Else
    
        For i = 1 To n           ' Wenn transparent, dann nur Pixel des Textes
        
            If Col(i) <> bk Then ' berücksichtigen
            
                Dest.PSet (Xi + x(i), Yi + y(i)), Col(i)
                
            End If
            
        Next i
        
    End If
    
exi:

    ' Rücksprungmarke nach Fehlerbehandlung
    ' Scalemode zurücksetzen und Objekte löschen
    Dest.ScaleMode = sm
    Dest.DrawWidth = dw
    Frm.Controls.Remove Pic
    
    Set Pic = Nothing
    
    Exit Function
    
err1:

    Select Case Err
    
    Case 438
        RotatedTextOut = Err
        Goto exi
        
    Case Else
        RotatedTextOut = Err
        
        ' Resume
        MsgBox Error$
        
        Goto exi
        
    End Select
    
End Function

' ---------- Ende Modul "Module1" alias Module1.bas ----------
' -------------- Ende Projektdatei Project1.vbp --------------