VB 5/6-Tipp 0783: Diagramme in Fließtext Einbinden und Druckvorschau

von Klaus Langbein

Beschreibung

In diesem Tipp wird gezeigt, wie man selbsterstellete Diagramme in Fließtext einbinden kann um eine Druckvorschau zu erstellen. Ränder können eingestellt werden und die Diagramme werden automatisch einer der vom Text vorgegebenen Position dargestellt. Diagramme und Text können wie in der Vorschau eingestellt, gedruckt werden.
Schwierigkeitsgrad:
Schwierigkeitsgrad 1
Verwendete API-Aufrufe:
keine
Download:
Download des Beispielprojektes [5,95 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 PrjPrintPreview.vbp  ---------
'--- Anfang Formular "frmPreview" alias frmPrintPreview.frm ---
' Steuerelement: Schaltfläche "cmdDraw" (Index von 0 bis 1)
' Steuerelement: Bildfeld-Steuerelement "picContainer"
' Steuerelement: Horizontale Scrollbar "HScroll1" auf picContainer
' Steuerelement: Vertikale Scrollbar "VScroll1" auf picContainer
' Steuerelement: Bildfeld-Steuerelement "picPage" auf picContainer
' Steuerelement: Linien-Steuerelement "linCurs" (Index von 0 bis 0) auf picPage
' Steuerelement: Beschriftungsfeld "LabelY"
' Steuerelement: Beschriftungsfeld "LabelX"
' Druckvorschau und Drucken einer Zeichnung mit Text
' Din A4-Seite als PictureMarginx darstellen und scrollen
'
'
' Autor/Copyright: K. Langbein, ActiveVB.de
'
' Benötigt: PictureMarginx namens PicContainer
'           In PicContainer: PictureMarginx namens PicPage
'           Auserdem in PicContainer: Hscroll1, Vscroll1
'           In PicPage: ein Line-Control namens linCurs mit Index 0
'           (Achtung linCurs(0) nicht verwenden!)
'           Auf Form: cmdDraw(0), cmdDraw(1), LabelX und LabelY


Dim twpp As Long
Dim cix As Long

Dim xFact As Double
Dim yFact As Double
Dim xOff As Double
Dim yOff As Double

Dim xMax As Double
Dim yMax As Double
Dim xMin As Double
Dim yMin As Double

Dim MarginLeft As Double
Dim MarginRight As Double
Dim MarginTop As Double
Dim MarginBottom As Double

Dim DiagLeft As Double
Dim DiagTop As Double
Dim DiagWidth As Double
Dim DiagHeight As Double
Dim CursorMoved As Boolean

Option Explicit ' für Angsthasen

Function DrawBoundary(Obj As Object, _
                      ByVal Grey As Long, _
                      ByVal IsPrinter As Boolean) As Long
                      
    Dim ds As Long
    ds = Obj.DrawStyle
    Obj.ForeColor = RGB(Grey, Grey, Grey)
    
    If IsPrinter = True Then
        Obj.DrawStyle = 2
    Else
        Obj.DrawStyle = 0
    End If
    
    Obj.Line (DiagLeft, DiagTop)-(DiagLeft + DiagWidth, DiagTop + DiagHeight), , B
    Obj.DrawStyle = ds
    
End Function

Private Function DrawAxis(Obj As Object, Grey As Long, ByVal IsPrinter As Boolean) As Long

    Obj.ForeColor = RGB(Grey, Grey, Grey)

    ' Achsen Einzeichnen
    If IsPrinter = True Then
        Obj.DrawWidth = 5
    Else
        Obj.DrawWidth = 1
    End If
    
    Obj.Line (xxc(xMin), yyc(0))-(xxc(xMax), yyc(0)), , B
    Obj.Line (xxc(0), yyc(yMin))-(xxc(0), yyc(yMax)), , B

End Function

Private Function DrawFrame(Obj As Object, Grey As Long, ByVal IsPrinter As Boolean) As Long

    Obj.ForeColor = RGB(Grey, Grey, Grey)

    ' Achsen Einzeichnen
    If IsPrinter = True Then
        Obj.DrawWidth = 8
    Else
        Obj.DrawWidth = 1
    End If
    
    Obj.Line (xxc(xMin), yyc(yMin))-(xxc(xMax), yyc(yMax)), , B

End Function

Private Function DrawTicksX(Obj, ByVal n As Long, _
                            ByVal dw1 As Double, _
                            ByVal dw2 As Double, _
                            ByVal L As Double, _
                            ByVal IsPrinter As Boolean) As Long

    Dim x As Double
    Dim yy1 As Double
    Dim yy2 As Double
    Dim xx As Double
    
    If IsPrinter = True Then
        Obj.ForeColor = 0
        Obj.DrawWidth = dw2
    Else
        Obj.ForeColor = 0
        Obj.DrawWidth = dw1
    End If
    
    For x = xMin To xMax Step ((xMax - xMin) / n)

        yy1 = yyc(yMax)
        yy2 = yyc(yMax) + L
        xx = (xxc(x))
        Obj.Line (xx, yy1)-(xx, yy2)   ' Linie zeichnen

        yy1 = yyc(yMin)
        yy2 = yyc(yMin) - L
        Obj.Line (xx, yy1)-(xx, yy2)   ' Linie zeichnen

    Next x

End Function

Private Function DrawTicksY(Obj, ByVal n As Long, _
                            ByVal dw1 As Double, _
                            ByVal dw2 As Double, _
                            ByVal L As Double, _
                            ByVal IsPrinter As Boolean) As Long

    Dim y As Double
    Dim xx1 As Double
    Dim xx2 As Double
    Dim yy As Double

    If IsPrinter = True Then
        Obj.ForeColor = 0
        Obj.DrawWidth = dw2
    Else
        Obj.ForeColor = 0
        Obj.DrawWidth = dw1
    End If

    For y = yMin To yMax Step (yMax - yMin) / n

        xx1 = xxc(xMax)
        xx2 = xxc(xMax) - L
        yy = (yyc(y))
        Obj.Line (xx1, yy)-(xx2, yy)   ' Linie zeichnen

        xx1 = xxc(xMin)
        xx2 = xxc(xMin) + L
        yy = (yyc(y))
        Obj.Line (xx1, yy)-(xx2, yy)   ' Linie zeichnen

    Next y
    
End Function

Function Fact() As Long

    ' Die Variablen xMax, yMax, Margin etc werden nicht an die
    ' Funktion Fact übergeben, weil sie Formweit benötigt werden
    ' Umrechnungsfaktoren bestimmen
    
    xFact = (DiagWidth - MarginLeft - MarginRight) / (xMax - xMin)
    yFact = (DiagHeight - MarginTop - MarginBottom) / (yMax - yMin)
    
    xOff = DiagLeft + MarginLeft + Abs(xMin) * xFact
    yOff = DiagTop + MarginTop + Abs(yMax) * yFact
    yFact = -yFact ' Dies tun wir um die Skala umzukehren
    
End Function

                        
Public Function FlowText(Obj As Object, _
                         ByVal Text$, _
                         ByVal xStart As Double, _
                         ByVal Left As Double, _
                         ByVal Top As Double, _
                         ByVal Width As Double, _
                         Optional ByVal Height As Double = -1 _
                         ) As Long
                         
    Dim Word() As String
    Dim tLine() As String
    Dim x As Double
    Dim y As Double
    Dim xMax As Double
    Dim yMax As Double
    Dim th As Double
    Dim tw As Double
    Dim ws As Double
    Dim i As Long
    Dim j As Long
    
    tLine() = Split(Text$, vbCrLf)
    
    x = Left + xStart
    xMax = Left + Width
    Obj.CurrentX = x
    y = Top
    Obj.CurrentY = y
    
    th = Obj.TextHeight("H")
    ws = Obj.TextWidth(" ")
    
    For j = 0 To UBound(tLine)
    
        Word() = Split(tLine(j), " ")
        
        For i = 0 To UBound(Word)
            
            tw = Obj.TextWidth(Word(i))
            If x + tw > xMax Then
                x = Left
                y = y + th
            End If
            Obj.CurrentX = x
            Obj.CurrentY = y
            Obj.Print Word(i) & " ";
            x = x + tw + ws
            
        Next i
        
        If j < UBound(tLine) Then
            x = Left
            y = y + th
        End If
        
    Next j
                         
End Function


Function Legend(Obj As Object, _
                ByVal LegendX$, _
                ByVal LegendY$, _
                ByVal Left As Double, _
                ByVal Top As Double, _
                ByVal Height As Double) As Long

    Dim Text$
    Dim cnt As Long
    Dim tw As Double
    Dim th As Double
    Dim x As Double
    Dim y As Double

    Obj.FontName = "Arial"
    Obj.FontSize = 11
    Text$ = LegendX$
    tw = Obj.TextWidth(Text) / 2
    th = Obj.TextHeight(Text) / 2
    Obj.CurrentY = Top + Height - MarginBottom / 2 - th
    Obj.CurrentX = xxc(0) - tw
    Obj.Print Text
    
    Text$ = LegendY$
    tw = Obj.TextWidth(Text) / 2
    Obj.CurrentX = Left + MarginLeft / 2 - tw
    Obj.CurrentY = yyc(0.6)
    Obj.Print Text

End Function

'2345678901234567890123456789012345678901234567890123456789012345678901234567890
Function PrintPage(Obj As Object) As Long

    Dim Text$
    Dim tw As Double
    Dim th As Double
    Dim w As Double
    Dim h As Double
    Dim wMax As Double
    Dim hMax As Double
    Dim x As Double
    Dim y As Double
    Dim dx As Double
    Dim IsPrinter As Boolean
    Dim i As Long
    Dim ret As Long
    
    If TypeOf Obj Is Printer Then
        IsPrinter = True
    End If
    
    If IsPrinter = True Then
        Printer.Print " "     ' braucht man zur Initialisierung des Druckers
    Else
        picPage.Cls
    End If
    
    Obj.ScaleMode = vbMillimeters
    Obj.FontName = "Arial"
    Obj.FontSize = 18
    Obj.FontItalic = False
    Text$ = "Titelzeile"
    tw = Obj.TextWidth(Text$)
    w = (linCurs(2).X1 - linCurs(1).X1)
    Obj.CurrentX = linCurs(1).X1 + w / 2 - tw / 2
    Obj.CurrentY = linCurs(3).Y1
    Obj.Print Text$
    Obj.Print

    Obj.FontSize = 12

    Text$ = "Hier beginnt nun endlich der Text. Bla bla bla blah, bla bla bla, "
    Text$ = Text$ & "so ein dummes Geschwätz... Nochmehr bla bla bla blaaaa "
    Text$ = Text$ & "und weil es so schön ist, versuchen wir noch ein wenig "
    Text$ = Text$ & "intelligent zu wirken, weil sonst - was würden denn die "
    Text$ = Text$ & "Leute sagen? Die würden ja glatt behaupten, dass das alles "
    Text$ = Text$ & "nur dummes Geschwätz ist, was wir da schreiben."
    
    th = Obj.TextHeight("H")
    w = linCurs(2).X1 - linCurs(1).X1
    ret = FlowText(Obj, Text$, 15, linCurs(1).X1, Obj.CurrentY, w)
    wMax = 130
    hMax = 80
    If w > wMax Then
        dx = (w - wMax) / 2
        w = wMax
        h = hMax
    Else
        dx = 0
        h = w * (hMax / wMax)
    End If
    x = linCurs(1).X1 + dx
    y = Obj.CurrentY + 3 * th
    
    Call Draw(Obj, x, y, w, h)
    y = y + h
    Obj.CurrentY = y
    Obj.CurrentX = x
    
    Obj.FontSize = 11
    Obj.FontItalic = True
    Text = "Fig.1 Streuung der Temperaturmessung am Ofeneingang"
    
    ret = FlowText(Obj, Text$, 0, x, y, w)
    
    Obj.Print
    Obj.Print
    
    Obj.FontSize = 12
    Obj.FontItalic = False
    
    Text = "Und hier gehts weiter im Text, bla, bla, bla, nun müssen wir darauf "
    Text$ = Text$ & "achten, dass das ganze nicht zu langweilig wird, weil sonst "
    Text$ = Text$ & "keiner weiterliest in der Annahme das hier nur dummes "
    Text$ = Text$ & "Geschwätz geschrieben wurde. Schließlich haben wir ja "
    Text$ = Text$ & "einen Ruf zu verlieren. Also wenigstens fehlerfrei sollte "
    Text$ = Text$ & "der Text schon sein."
    
    x = linCurs(1).X1
    y = Obj.CurrentY
    w = linCurs(2).X1 - linCurs(1).X1
    ret = FlowText(Obj, Text$, 0, x, y, w)
    
    ' Fußzeile
    Obj.FontSize = 8
    Obj.CurrentX = linCurs(1).X1
    Obj.CurrentY = linCurs(4).Y1
    Text$ = "Fußzeile: Bitte nur mit sauberen Füßen betreten."
    Obj.Print Text$;
    
    ' Kopfzeile (Seitennummer)
    Obj.FontSize = 10
    Text$ = "- 1 -"
    tw = Obj.TextWidth(Text$)
    Obj.CurrentX = Obj.ScaleWidth / 2
    Obj.CurrentY = 10
    Obj.Print Text$;
   
    If IsPrinter = True Then
        Printer.EndDoc
    End If

End Function

Private Sub cmdDraw_Click(Index As Integer)

    Dim Obj As Object
    If Index = 0 Then
        Call PrintPage(picPage)
    Else
        Call PrintPage(Printer)
    End If

End Sub

Private Sub Form_Load()

    Dim i As Long
    
    Me.Width = 10000
    Me.Height = 8000
    'picPage.AutoRedraw = True
    picPage.Appearance = 0
    picPage.BackColor = vbWhite
    
    cmdDraw(0).Caption = "Preview"
    cmdDraw(1).Caption = "Print"
    
    HScroll1.Max = 32000
    VScroll1.Max = 32000
    
    HScroll1.Min = 0
    VScroll1.Min = 0
    
    HScroll1.LargeChange = 16000
    VScroll1.LargeChange = 16000
    
    twpp = Screen.TwipsPerPixelX
    picPage.Width = ScaleX(211, vbMillimeters, vbTwips)
    picPage.Height = picPage.Width * Sqr(2)
    
    linCurs(0).BorderColor = vbBlue
    linCurs(0).BorderStyle = 3
    linCurs(0).Visible = 0
    For i = 1 To 4
        Load linCurs(i)
        linCurs(i).Visible = True
    Next i
    
    ' linker Rand. Muß wegen Papiereinzug an Drucker angepaßt werden
    linCurs(1).X1 = ScaleX(20, vbMillimeters, vbTwips)
    linCurs(1).X2 = linCurs(1).X1
    linCurs(1).Y1 = 0
    linCurs(1).Y2 = picPage.ScaleHeight
    
    linCurs(2).X1 = picPage.ScaleWidth - ScaleX(20, vbMillimeters, vbTwips)
    linCurs(2).X2 = linCurs(2).X1
    linCurs(2).Y1 = 0
    linCurs(2).Y2 = picPage.ScaleHeight
    
    linCurs(3).Y1 = ScaleY(25, vbMillimeters, vbTwips)
    linCurs(3).Y2 = linCurs(3).Y1
    linCurs(3).X1 = 0
    linCurs(3).X2 = picPage.ScaleWidth
    
    linCurs(4).Y1 = picPage.ScaleHeight - ScaleY(20, vbMillimeters, vbTwips)
    linCurs(4).Y2 = linCurs(4).Y1
    linCurs(4).X1 = 0
    linCurs(4).X2 = picPage.ScaleWidth
    
    picPage.ScaleMode = 6
    picPage.AutoRedraw = True
    
    
End Sub

Private Sub Form_Resize()

    Dim T As Single
    Dim L As Single
    Dim w As Single
    Dim h As Single

    w = Me.ScaleWidth - picContainer.Left
    h = Me.ScaleHeight - picContainer.Top - picContainer.Left * 2
    L = picContainer.Left
    T = picContainer.Top
    picContainer.Move L, T, w, h
    
    T = picContainer.ScaleHeight - HScroll1.Height
    h = picContainer.ScaleWidth - VScroll1.Width
    HScroll1.Move 0, T, h
    
    L = picContainer.ScaleWidth - VScroll1.Width
    h = picContainer.ScaleHeight - HScroll1.Height
    w = VScroll1.Width
    VScroll1.Move L, 0, w, h
    

End Sub

Private Sub HScroll1_Change()
    picPage.SetFocus
End Sub

Private Sub HScroll1_Scroll()

    Dim diff As Double
    
    diff = picPage.Width - HScroll1.Width + 5 * twpp
    picPage.Left = 2 * twpp - diff * HScroll1.Value / HScroll1.Max
    picPage.SetFocus
 
End Sub

Private Sub mnuFile_Click()
    MsgBox mnuFile.Caption
End Sub

Private Sub picPage_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    
    Dim i As Long
    Dim dx As Single
    Dim dy As Single
    
    cix = 0
    For i = 1 To 2
        dx = Abs(linCurs(i).X1 - x)
        dx = picPage.ScaleX(dx, picPage.ScaleMode, 3)
        If dx < 2 Then
            cix = i
            Exit Sub
        End If
    Next i
    
    For i = 3 To 4
        dy = Abs(linCurs(i).Y1 - y)
        dy = picPage.ScaleY(dy, picPage.ScaleMode, 3)
        If dy < 2 Then
            cix = i
            Exit Sub
        End If
    Next i
    
End Sub

Private Sub picPage_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

    If cix > 0 And Button <> 0 Then
    
        If cix < 3 Then
            
            linCurs(cix).X1 = x
            linCurs(cix).X2 = x
        Else
            linCurs(cix).Y1 = y
            linCurs(cix).Y2 = y
        End If
        CursorMoved = True
    End If
    
    LabelX.Caption = "x: " & Format$(x, "0.0")
    LabelY.Caption = "y: " & Format$(y, "0.0")

End Sub

Private Sub picPage_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    
    cix = 0
    If CursorMoved = True Then
        Call cmdDraw_Click(0)
    End If
    
End Sub

Private Sub VScroll1_Change()

    picPage.SetFocus
  
End Sub

Private Sub VScroll1_Scroll()

    Dim diff As Double
    
    diff = picPage.Height - VScroll1.Height + 5 * twpp
    picPage.Top = 2 * twpp - diff * VScroll1.Value / VScroll1.Max

End Sub

Function Draw(Obj As Object, _
              ByVal Left As Double, _
              ByVal Top As Double, _
              ByVal Width As Double, _
              ByVal Height As Double) As Long
    
         
    Dim IsPrinter As Boolean
    Dim x As Double
    Dim y As Double
    Dim w As Double
    Dim h As Double
    Dim n As Long
    Dim a As Double
    Dim cnt As Long
    
    If TypeOf Obj Is Printer Then
        IsPrinter = True
    End If
    
    DiagLeft = Left
    DiagTop = Top
    DiagWidth = Width
    DiagHeight = Height
        
    ' Ränder inderhalb des Zeichenbereichs
    MarginLeft = 10
    MarginRight = 3
    MarginTop = 3
    MarginBottom = 10
    
    ' Minimal- und Maximalwerte des Diagramms (unabh. von der Ausgabe)
    xMin = -3
    xMax = 3
    yMin = -0.1
    yMax = 1.1
    
    Call Fact
    Call DrawBoundary(Obj, 200, IsPrinter)
    Call DrawFrame(Obj, 0, IsPrinter)
    Call DrawAxis(Obj, 120, IsPrinter)
    Call DrawTicksX(Obj, 30, 1, 3, 1, IsPrinter)
    Call DrawTicksX(Obj, 6, 1, 5, 2, IsPrinter)
    Call DrawTicksY(Obj, 12, 1, 5, 1, IsPrinter)
    
    n = 1000
    a = 1
    
    If IsPrinter = True Then
        Obj.ForeColor = 0
        Obj.DrawWidth = 8
    Else
        Obj.ForeColor = 0
        Obj.DrawWidth = 1
    End If
    
    For x = xMin To xMax Step (xMax - xMin) / n
    
        y = a * Exp(-x ^ 2)           ' Hier die eigentliche Formel
        
        If cnt = 0 Then
            cnt = 1                   ' Flag
            Obj.PSet (xxc(x), yyc(y)) ' Anfangposition setzen
        End If
        
        Obj.Line -(xxc(x), yyc(y))    ' Linie zeichnen
    
    Next x
    
    Call Legend(Obj, "T (°C)", "%", Left, Top, Height)

End Function
Function yyc(ByVal y As Double) As Double

    yyc = yOff + y * yFact

End Function

Function xxc(ByVal x As Double) As Double

    xxc = xOff + x * xFact

End Function
'--- Ende Formular "frmPreview" alias frmPrintPreview.frm ---
'---------- Ende Projektdatei PrjPrintPreview.vbp  ----------
Tipp-Kompatibilität:
Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6
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.