Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0617: Einen Text als Blocksatz ausgeben

 von 

Beschreibung 

Dieser Tipp zeigt, wie man einen Text in einen Blocksatz ausgibt. Dies kann sowohl auf einer Picturebox, als auch auf einem Drucker erfolgen.

Zu diesem Tipp existieren im Tippupload die folgende(n) Aktualisierung(en):
[VB 5/6 Tippvorschlag 0381] Korrektur VB 617

Schwierigkeitsgrad:

Schwierigkeitsgrad 3

Verwendete API-Aufrufe:

SendMessageA (SendMessage)

Download:

Download des Beispielprojektes [5,4 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 PrintBlockSatz.vbp ----------
'--- Anfang Formular "frmBlocksatz" alias frmBlocksatz.frm  ---
' Steuerelement: Schaltfläche "Command3"
' Steuerelement: Kontrollkästchen-Steuerelement "Check1"
' Steuerelement: Kombinationsliste "Combo2"
' Steuerelement: Kombinationsliste "Combo1"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Textfeld "Text1"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Beschriftungsfeld "Label1"

Option Explicit

Private BlockSatzFile As String

Private Sub Check1_Click()
    Text1.FontBold = Check1.Value * -1
End Sub

Private Sub Combo1_Click()
    Text1.FontName = Combo1.List(Combo1.ListIndex)
End Sub

Private Sub Combo2_Click()
    Text1.FontSize = Val(Combo2.List(Combo2.ListIndex))
End Sub

Private Sub Command1_Click()
    Dim FNr As Integer
    
    FNr = FreeFile
    Open BlockSatzFile For Output As #FNr
    Print #FNr, Text1.Text;
    Close #FNr
End Sub

Private Sub DoPrint(prnObj As Object)
    Dim s() As String
    Dim i As Long, j As Long
    Dim w As Single
    Dim x As Single
    Dim aTime As Single
    
    aTime = Timer
    
    'zur Messung auf  For j = 1 To 100
    For j = 1 To 1
        'Textbox auslesen in Array
        s() = TextboxLinesToArray(Text1)
        
        'benötigte Breite für Blocksatz ermitteln
        w = BlockSatzWidth(prnObj, s(), Text1.FontName, Text1.FontSize, Text1.FontBold)
        
        x = prnObj.CurrentX
        For i = LBound(s) To UBound(s)
            BlocksatzZeilePrint prnObj, s(), i, x, w
        Next
   Next j
   
   Label1.Caption = Format(Timer - aTime, "0.00000")
End Sub

Private Sub Command2_Click()
    With Picture1
        .Cls
        .CurrentX = 600
        .CurrentY = 150
    End With
    
    DoPrint Picture1
End Sub

Private Sub Command3_Click()
    Printer.CurrentX = 1000
    Printer.CurrentY = 2000
    
    DoPrint Printer
    Printer.EndDoc
End Sub

Private Sub Form_Load()
    Dim FNr As Integer
    Dim s As String
    Dim i As Long
    
    BlockSatzFile = App.Path
    If Right(App.Path, 1) <> "\" Then BlockSatzFile = BlockSatzFile & "\"
    
    BlockSatzFile = BlockSatzFile & "blocksatz.txt"
    
    If Len(Dir(BlockSatzFile)) > 0 Then
        FNr = FreeFile
        Open BlockSatzFile For Binary As #FNr
            s = Space$(LOF(FNr))
            Get #FNr, , s
        Close #FNr
    End If
    
    Text1.Text = s
    
    Command1.Caption = "SaveFile"
    Command2.Caption = "Picturebox"
    Command3.Caption = "Printer"
    Label1.Caption = ""
    Check1.Caption = "Bold"
    
    For i = 0 To Printer.FontCount - 1
        Combo1.AddItem Printer.Fonts(i)
    Next i
    
    Combo1.ListIndex = 0
    For i = 0 To Combo1.ListCount - 1
        If LCase(Combo1.List(i)) = "arial" Then
            Combo1.ListIndex = i
            Exit For
        End If
    Next i
    
    Combo2.AddItem 8
    Combo2.AddItem 10
    Combo2.AddItem 12
    Combo2.AddItem 14
    Combo2.AddItem 16
    Combo2.AddItem 20
    Combo2.AddItem 24
    Combo2.ListIndex = 1
End Sub


'--- Ende Formular "frmBlocksatz" alias frmBlocksatz.frm  ---
'---- Anfang Modul "modBlockSatz" alias modBlockSatz.bas ----



'###################################################################
'
'     modBlockSatz.bas
'
'     Funktionen für Blocksatz Print
'
'     (c) peter.k.sauer@web.de   07.2003
'     nur für den persönlichen nicht gewerblichen Gebrauch
'-------------------------------------------------------------------

Option Explicit

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
                (ByVal hWnd As Long, ByVal wMsg As Long, _
                ByVal wParam As Long, lParam As Any) As Long

Private Const EM_GETLINE = &HC4
Private Const EM_GETLINECOUNT = &HBA
Private Const EM_SCROLLCARET = &HB7
Private Const EM_LINELENGTH = &HC1
Private Const EM_LINEINDEX = &HBB

Private Type PrnFormatType
    Top As Single
    Left As Single
    Width As Single
    Height As Single
End Type
   
Private PrnFormat As PrnFormatType

'Anzahl der Zeilen einer Textbox ausgeben
Public Function TextBoxLineCount(ByRef Tbox As Control) As Long
    TextBoxLineCount = SendMessage(Tbox.hWnd, EM_GETLINECOUNT, 0, 0&)
End Function


'einzelne Line einer (Rich) Textbox ausgeben (Line 0 to n)
Public Function TextBoxLine(ByRef Tbox As Control, _
                    ByVal LineNr As Long) As String

   Dim LineLength As Long
   Dim LineStart As Long
   
    'ermitteln Beginn Zeile und Länge
    LineStart = SendMessage(Tbox.hWnd, EM_LINEINDEX, LineNr, ByVal 0&)
    LineLength = SendMessage(Tbox.hWnd, EM_LINELENGTH, LineStart, ByVal 0&)

    'aus Textbox separieren
    TextBoxLine = Mid$(Tbox, LineStart + 1, LineLength)
End Function

'Position einer Zeile im Text
Public Function TextboxLineStart(ByRef Tbox As Control, LineNr As Long) As Long
    TextboxLineStart = SendMessage(Tbox.hWnd, EM_LINEINDEX, LineNr, ByVal 0&)
End Function

'Länge einer Zeile
Public Function TextboxLineLength(ByRef Tbox As Control, LineNr As Long) As Long
    Dim LineChar As Long
    
    LineChar = SendMessage(Tbox.hWnd, EM_LINEINDEX, LineNr, ByVal 0&)
    TextboxLineLength = SendMessage(Tbox.hWnd, EM_LINELENGTH, LineChar, ByVal 0&)
End Function

'Textbox in ein Array ausgeben
Public Function TextboxLinesToArray(Tbox As Control) As String()
    Dim s() As String
    Dim i As Long
    
    i = TextBoxLineCount(Tbox)
    If i = 0 Then
        ReDim s(0)
    Else
        ReDim s(i - 1)
        For i = 0 To UBound(s)
            s(i) = TextBoxLine(Tbox, i)
        Next i
    End If
    
    TextboxLinesToArray = s()
End Function

'Breite für einen Blocksatz aus einem Array ermitteln
Public Function BlockSatzWidth(prnObj As Object, sString() As String, _
                     FontName As String, FontSize As Long, _
                     FontBold As Boolean) As Single

    Dim MaxWidth As Single, w As Single
    Dim i As Long
    Dim s As String
    
    'Schrift einrichten
    prnObj.FontName = FontName
    prnObj.FontSize = FontSize
    prnObj.FontBold = FontBold
    
    'maximale Breite einer Zeile feststellen
    For i = LBound(sString) To UBound(sString)
        sString(i) = RTrim(sString(i))
        w = prnObj.TextWidth(sString(i))
        
        If w > MaxWidth Then
            MaxWidth = w
        End If
    Next i
    
    BlockSatzWidth = MaxWidth
End Function

'Zeile auf Blocksatzlänge ausdrucken
Public Function BlocksatzZeilePrint(prnObj As Object, sString() As String, _
                        Zeile As Long, StartPosX As Single, _
                        MaxWidth As Single) As Boolean
                         
   Dim s() As String
   Dim tb() As Single
   Dim AnzWorte As Long, AnzPixel As Long
   Dim AnzProWort As Single
   Dim i As Long, j As Long
   Dim w As Single
   Dim x As Single
   Dim PrintDirect As Boolean
   
    'linker Rand
    prnObj.CurrentX = StartPosX
   
    If Len(Trim(sString(Zeile))) = 0 Then
        'nix bei Leerzeile
        PrintDirect = True
    ElseIf Zeile = UBound(sString) Then
        'nix bei letzter Zeile
        PrintDirect = True
    ElseIf Len(Trim(sString(Zeile + 1))) = 0 Then
        'nix wenn Leerzeile folgt
        PrintDirect = True
    End If
        
    w = prnObj.TextWidth(sString(Zeile))
    If w = MaxWidth Then
        'ist breiteste Zeile, drucken und weg
        PrintDirect = True
    End If
   
    If PrintDirect Then
        prnObj.Print sString(Zeile)
        BlocksatzZeilePrint = True
        Exit Function
    End If
   
    'Zeile auf Wörter aufsplitten
    s() = Split(sString(Zeile), Space(1))
    
    'wieviele Wörter insgesamt ohne letztes Wort
    For i = LBound(s) To UBound(s) - 1
        If RTrim(s(i)) > 0 Then
            AnzWorte = AnzWorte + 1
        End If
    Next i
    
    'Breite ohne Optimierung feststellen
    w = prnObj.TextWidth(sString(Zeile))
    
    'Breite eines Pixels auf Scalemode der Ausgabe
    x = prnObj.ScaleX(1, vbPixels, prnObj.ScaleMode)
    
    'benötigte Pixel
    AnzPixel = (MaxWidth - w) \ x
    
    'für Verteilung
    ReDim tb(UBound(s))
    
    'LeerPixel pro Wort ermitteln
    Do
        For i = UBound(s) - 1 To LBound(s) Step -1
            If Len(s(i)) > 0 Then
                tb(i) = tb(i) + 1
                AnzPixel = AnzPixel - 1
            End If
            
            If AnzPixel = 0 Then
                Exit Do
            End If
        Next i
    Loop
    
    'Ausgabe der einzelnen Wörter
    For i = LBound(s) To UBound(s)
        'Wort mit folgendem Space
        prnObj.Print s(i) & Space(1);
        
        'verschieben um x Pixel
        prnObj.CurrentX = prnObj.CurrentX + (tb(i) * x)
    Next i
    
    'Rücklauf mit Zeilenvorschub
    prnObj.Print ""
    
    BlocksatzZeilePrint = True
End Function
'----- Ende Modul "modBlockSatz" alias modBlockSatz.bas -----
'----------- Ende Projektdatei PrintBlockSatz.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.

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 3 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.

Kommentar von Peter Siepe am 11.02.2008 um 09:48

Hallo, gibt es noch ne möglichkeit für nen blocksatz,
ausser so fett und .. hmm, umständlich ?


Gruß

P. siepe

Kommentar von C.Stricker am 19.07.2005 um 13:04

Ist es wirklich nur möglich über eine Picturebox den Blocksatz hinzukriegen. Mir würde es besser gefallen , wenn es so wie in Word funktionieren würde.

Kommentar von Patrick Hegemann am 22.02.2004 um 12:27

bei mir funktioniert das Programm nicht weil ich keinen Drucker habe deswegen bringt er die fehlermeldung

Lufzeitfehler'482':
Druckerfehler

bei der folgenden Zeile:
For i = 0 To Printer.FontCount - 1