Tipp-Upload: VB 5/6 0381: Korrektur VB 617

Über den Tipp  

Dieser Vorschlag soll VB 5/6 Tipp 617 ersetzen.

Dieser Tippvorschlag ist noch unbewertet.

Der Vorschlag ist in den folgenden Kategorien zu finden:

• Drucker

Dem Tippvorschlag wurden folgende Schlüsselwörter zugeordnet:
Drucken, Blocksatz, Korrektur

Damit er übernommen werden kann, müssen noch Änderungen daran vorgenommen werden. Sofern Sie der Autor sind, können Sie sich anmelden, um die Liste einzusehen.

Der Vorschlag wurde erstellt am: 17.11.2009 11:07.
Die letzte Aktualisierung erfolgte am 17.11.2009 11:09.

Zurück zur Übersicht

Beschreibung  

geringfügige Korrektur eines bestehenden Tipps

(Der Tipp stammt nicht von mir, nur die Korrektur. Das Projekt-Upload ist per E-Mail angefordert worden.)

Schwierigkeitsgrad

Verwendete API-Aufrufe: SendMessageA (SendMessage)

Download: Download des Beispielprojektes [4,31 KB]

' Dieser Source 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 pBlocksatz.vbp ------------

' --- Anfang Formular "frmBlocksatz" alias frmBlocksatz2.frm ---

' Steuerelement: Beschriftungsfeld "Label1"
' Steuerelement: Kombinationsliste "Combo1"
' Steuerelement: Textfeld "Text1"
' Steuerelement: Schaltfläche "Command2"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Schaltfläche "Command3"
' Steuerelement: Kontrollkästchen-Steuerelement "Check1"
' Steuerelement: Kombinationsliste "Combo2"

' 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"                        MultiLine = true
' Steuerelement: Bildfeld-Steuerelement "Picture1"       AutoRedraw = true
' 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 ----

' --- Ende Formular "frmBlocksatz" alias frmBlocksatz2.frm ---

' --- Anfang Modul "modBlockSatz" alias modBlockSatz2.bas  ---

' ###################################################################
'
'     modBlockSatz.bas
'
'     Funktionen für Blocksatz Print
'
'     (c) peter.k.sauer@web.de   07.2003 - korrigiert 11.2009
'     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
    If AnzPixel > 0 And UBound(s) > LBound(s) Then

        Do

            For i = UBound(s) - 1 To LBound(s) Step -1

                If RTrim(s(i)) > 0 Or AnzWorte = 0 Then
                    tb(i) = tb(i) + 1
                    AnzPixel = AnzPixel - 1
                End If

                If AnzPixel = 0 Then

                    Exit Do

                End If

            Next i

        Loop

    End If

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

' ---- Ende Modul "modBlockSatz" alias modBlockSatz2.bas  ----

' ------------- Ende Projektdatei pBlocksatz.vbp -------------

	

Diskussion  

Diese Funktion ermöglicht es, Fragen, die die Veröffentlichung des Tipps betreffen, zu klären, oder Anregungen und Verbesserungsvorschläge einzubringen. Nach der Veröffentlichung des Tipps werden diese Beiträge nicht weiter verlinkt. Allgemeine Fragen zum Inhalt sollten daher hier nicht geklärt werden.
Folgende Diskussionen existieren bereits

Um eine Diskussion eröffnen zu können, müssen sie angemeldet sein.