Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0561: Fehler in der Richtextbox beheben

VB 5/6-Tipp 0561: Fehler in der Richtextbox beheben

 von Ralf Knörr

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CreateDCA (CreateDC), DeleteDC, GetCaretPos, GetDeviceCaps, SendMessageA (SendMessage)

Download: Download des Beispielprojektes [5,67 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 Projekt1.vbp -------------
' Die Komponente 'Microsoft Rich Textbox Control 6.0 (RICHTX32.OCX)' wird benötigt.
' Die Komponente 'Microsoft Common Dialog Control 6.0 (SP3) (COMDLG32.OCX)' wird benötigt.

'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Standarddialog-Steuerelement "CommonDialog1"
' Steuerelement: RichTextBox "RichTextBox1"
' Steuerelement: Menü "Menu" (Index von 0 bis 10)
' Steuerelement: Menü "menuDatei" (Index von 0 bis 99) auf Menu

'
'Autor: Ralf Knörr <rfknoerr@t-online.de>

Option Explicit

Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal _
        hDC As Long, ByVal nIndex As Long) As Long

Private 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 Declare Function CreateDC Lib "gdi32" Alias _
        "CreateDCA" (ByVal lpDriverName As String, ByVal _
        lpDeviceName As String, ByVal lpOutput As Long, _
        ByVal lpInitData As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC _
        As Long) As Long
        
Private Const PHYSICALOFFSETX As Long = 112
Private Const PHYSICALOFFSETY As Long = 113
Private Const WM_USER As Long = &H400
Private Const EM_GETLINECOUNT As Long = &HBA
Private Const EM_LINEFROMCHAR As Long = &HC9
Private Const EM_FORMATRANGE As Long = WM_USER + 57
Private Const EM_SETTARGETDEVICE As Long = WM_USER + 72
Private Const EM_SCROLLCARET As Long = &HB7
Private Const EM_SCROLL As Long = &HB5
Private Const EM_LINESCROLL As Long = &HB6
Private Const EM_GETFIRSTVISIBLELINE As Long = &HCE
Private Const EM_LINELENGTH As Long = &HC1
Private Const EM_LINEINDEX As Long = &HBB

Private Type Rect
      Left As Long
      Top As Long
      Right As Long
      Bottom As Long
End Type

Private Type CharRange
  cpMin As Long
  cpMax As Long
End Type

Private Type FormatRange
  hDC As Long
  hdcTarget As Long
  rc As Rect
  rcPage As Rect
  chrg As CharRange
End Type

Dim PrtDC As Long
Dim ObererRand As Long
Dim LinkerRand As Long
Dim RechterRand As Long
Dim UntererRand As Long

Private Declare Function GetCaretPos Lib "user32" _
        (lpPoint As POINTAPI) As Long
        
Private Type POINTAPI
  X As Long
  Y As Long
End Type

Private LineWidth As Long  'Breite der RTB in der Text eingegeben werden kann

Private Sub Form_Load()

Dim BW&, BH&, r&
Dim TopOffSet As Long
Dim LeftOffSet As Long

' Randeinstellungen
' Angaben in Twips
ObererRand = 1000
LinkerRand = 1200
RechterRand = 1000
UntererRand = 1000

' Druckerränder
' Linken Offset auslesen
LeftOffSet = Printer.ScaleX(GetDeviceCaps(Printer.hDC, _
             PHYSICALOFFSETX), vbPixels, vbTwips)
   
Dim LeftMargin As Long
Dim RightMargin As Long
'Dim LineWidth As Long

' Eingestellter Druckbereich
LeftMargin = LinkerRand - LeftOffSet
RightMargin = (Printer.Width - RechterRand) - LeftOffSet

' Wird benötigt um der RTB die exacte Breite zu übergeben
LineWidth = RightMargin - LeftMargin

' Einen hDC vom Drucker erstellen für die RTB in WYSIWYG
PrtDC = CreateDC(Printer.DriverName, Printer.DeviceName, 0, 0)

' Der RTF sagen das sie sich dem Druckbild anpassen soll (WYSIWYG)
r = SendMessage(RichTextBox1.hwnd, EM_SETTARGETDEVICE, PrtDC, _
                ByVal LineWidth)

End Sub

Private Sub Form_Resize()
    RichTextBox1.Move 100, 100, Me.ScaleWidth - 200, Me.ScaleHeight - 200
End Sub

Private Sub Form_Unload(Cancel As Integer)
    DeleteDC PrtDC
End Sub

Private Sub Menu_Click(Index As Integer)
' aus Tipp 0221
If Index = 10 Then
    On Error Resume Next
    CommonDialog1.CancelError = True
    CommonDialog1.Flags = cdlCFBoth Or cdlCFTTOnly Or cdlCFEffects
    CommonDialog1.ShowFont
    If Err = 0 Then
        With RichTextBox1
            .SelFontName = CommonDialog1.FontName
            .SelFontSize = CommonDialog1.FontSize
            .SelBold = CommonDialog1.FontBold
            .SelItalic = CommonDialog1.FontItalic
            .SelStrikeThru = CommonDialog1.FontStrikethru
            .SelUnderline = CommonDialog1.FontUnderline
            .SelColor = CommonDialog1.Color
        End With
    End If
End If
End Sub

Private Sub menuDatei_Click(Index As Integer)
' aus Tipp 0221
On Error Resume Next
Select Case Index
    Case 0
        RichTextBox1.TextRTF = ""
    Case 10
        CommonDialog1.CancelError = True
        CommonDialog1.ShowOpen
        If Err = 0 Then
            RichTextBox1.LoadFile CommonDialog1.FileName
            Me.Caption = "WYSIWYG RichTextBox - " _
                         & CommonDialog1.FileName
        End If
    Case 15
        CommonDialog1.CancelError = True
        CommonDialog1.ShowSave
        If Err = 0 Then
            RichTextBox1.SaveFile CommonDialog1.FileName
        End If
    Case 18
        CommonDialog1.CancelError = True
        CommonDialog1.Flags = 0
        CommonDialog1.ShowPrinter
        If Err = 0 Then
            Call PrintRTB(RichTextBox1, LinkerRand, _
                          ObererRand, RechterRand, UntererRand)
        End If
    Case 99
        Unload Me
End Select


End Sub

Sub PrintRTB(RTF As RichTextBox, LeftMarginWidth As Long, _
             TopMarginHeight As Long, RightMarginWidth As Long, _
             BottomMarginHeight As Long)

'##########  aus Tipp 0221

Dim LeftOffSet As Long, TopOffSet As Long
Dim LeftMargin As Long, TopMargin As Long
Dim RightMargin As Long, BottomMargin As Long
Dim fr As FormatRange
Dim rcDrawTo As Rect
Dim rcPage As Rect
Dim TextLength As Long
Dim NextCharPosition As Long
Dim r As Long
Dim strHeader As String
Dim strFooter As String

    ' Kopf- und Fusszeile
    strHeader = "ActiveVB  " & Now
    strFooter = Mid$(Me.Caption, 23)

    'Initialisierung des Printers
    Printer.Print ""
    Printer.ScaleMode = vbTwips
    
    'Linken und Oberen Offset auslesen
    LeftOffSet = Printer.ScaleX(GetDeviceCaps(Printer.hDC, _
                                PHYSICALOFFSETX), vbPixels, _
                                vbTwips)
                                
    TopOffSet = Printer.ScaleY(GetDeviceCaps(Printer.hDC, _
                               PHYSICALOFFSETY), vbPixels, _
                               vbTwips)
   
    'Ränder berechnen
    LeftMargin = LeftMarginWidth - LeftOffSet
    TopMargin = TopMarginHeight - TopOffSet
    RightMargin = (Printer.ScaleWidth - RightMarginWidth) _
                   + LeftOffSet
                   
    BottomMargin = (Printer.ScaleHeight - BottomMarginHeight) _
                    + TopOffSet
    
    'Druckbarer Bereich in einer Variable speichern
    rcPage.Left = 0
    rcPage.Top = 0
    rcPage.Right = Printer.ScaleWidth
    rcPage.Bottom = Printer.ScaleHeight
    
    'Bereich in einer Veriable speichern, in dem gedruckt
    'werden soll
    rcDrawTo.Left = LeftMargin
    rcDrawTo.Top = TopMargin
    rcDrawTo.Right = RightMargin
    rcDrawTo.Bottom = BottomMargin
    
    'Druckerinstruktionen festlegen
    fr.hDC = Printer.hDC
    fr.hdcTarget = Printer.hDC
    fr.rc = rcDrawTo
    fr.rcPage = rcPage
    fr.chrg.cpMin = 0
    fr.chrg.cpMax = -1
    
    'Textlänge bestimmen
    TextLength = Len(RTF.Text)
    
    'Schriftgrösse/-art für Kopf-/Fusszeilen
    Printer.Font = "Courier New" '"Arial"
    Printer.FontSize = 11
       
    'Loop der alle Seiten ausdruckt
    Dim i As Integer:    i = 1
    Do
        'Text mit EM_FORMATRANGE ausdrucken
        NextCharPosition = SendMessage(RTF.hwnd, EM_FORMATRANGE, _
                                       1, fr)
        'Kopfzeile ausdrucken
        Printer.CurrentX = (Printer.ScaleWidth - _
                            Printer.TextWidth(strHeader)) / 2
                            
        Printer.CurrentY = (TopMargin - Printer.TextHeight("x")) _
                            / 2
                            
        Printer.Print strHeader
        'Fusszeile ausdrucken
        Printer.CurrentX = (Printer.ScaleWidth - _
                            Printer.TextWidth(strFooter)) / 2
                            
        Printer.CurrentY = BottomMargin + (Printer.ScaleHeight _
                           - BottomMargin - Printer.TextHeight("x")) _
                           / 2
                           
        Printer.Print strFooter
        'Seitennummer ausdrucken
        Printer.CurrentX = Printer.ScaleWidth - _
                           Printer.TextWidth("Seite " & i)
                           
        Printer.CurrentY = BottomMargin + (Printer.ScaleHeight - _
                           BottomMargin - Printer.TextHeight("x")) _
                           / 2
                           
        Printer.Print "Seite " & i
        'Falls alles ausgedruckt ist, Schleife verlassen
        If NextCharPosition >= TextLength Then Exit Do
        
        'Startposition für die nächste Seite
        fr.chrg.cpMin = NextCharPosition
        'Neue Seite beginnen
        Printer.NewPage
        Printer.Print ""
        fr.hDC = Printer.hDC
        fr.hdcTarget = Printer.hDC
        i = i + 1
    Loop
    
    'Druckauftrag abschliessen
    Printer.EndDoc
    
    'Control zurücksetzten
    r = SendMessage(RTF.hwnd, EM_FORMATRANGE, 0, ByVal CLng(0))
'####################################################

End Sub

Private Sub RichTextBox1_KeyPress(KeyAscii As Integer)

'###################################################################
'######### Die RTB hat zwei Fehler:
'######### 1.  In der RichTextBox bleibt der Cursor am Ende der Zeile stehen, wenn durch
'#########      Drücken der Leertaste ein Leerzeichen vor sich hergeschoben wird.
'######### 2.  Verschiebt man ein Wort durch drücken der Leertaste, bleibt der Cursor
'#########      beim Erreichen der nächsten Zeile stehen.
'#########
'######### Lösungsweg zu 1.
'######### Wenn 'RichTextBox1.SelStart < 2' keine Überprüfung notwendig, da sich der
'######### Cursor in der ersten Zeile befindet..
'######### Grafisches Ausmaß der aktuellen Zeile bis zur Cursor-Position
'######### ermitteln ('Call GetCaretPos(pt)' und 'pt.X * 15').
'######### Beim erreichen der maximalen Textbreite wird durch setzen von 'KeyAscii = 13'
'######### ein Zeilenumbruch erzeugt.
'#########
'######### Lösungsweg zu 2.
'######### Durch "LineLen" feststellen, ob sich der Cursor am Zeilenanfang befindet.
'######### Wenn 'KeyAscii_Code_nach_aktueller_Position' und
'######### 'KeyAscii_Code_vor_aktueller_Position' = 'KeyAscii = 13' ist, ist kein eingreifen
'######### notwendig.
'###################################################################

Dim pt As POINTAPI
Dim LineLen&
Dim KeyAscii_Code_nach_aktueller_Position As String
Dim KeyAscii_Code_vor_aktueller_Position As String

    
    If RichTextBox1.SelStart < 2 Then Exit Sub

    LineLen = RichTextBox1.SelStart - LineStart  'Länge der aktuellen Zeile bis Cursor

    Call GetCaretPos(pt)
     
    If pt.X * 15 >= LineWidth And KeyAscii = vbKeySpace Then
            KeyAscii = 13 ' Enter
            Exit Sub
    End If
    
    If LineLen > 0 Then Exit Sub
    
    If Len(RichTextBox1.Text) > RichTextBox1.SelStart Then
            KeyAscii_Code_nach_aktueller_Position = Asc(Mid(RichTextBox1.Text, _
            Format$(RichTextBox1.SelStart) + 1, 1))
    Else
            Exit Sub
    End If

    KeyAscii_Code_vor_aktueller_Position = Asc(Mid(RichTextBox1.Text, _
    Format$(RichTextBox1.SelStart) - 1, 1))
    
    If LineLen = 0 And KeyAscii = vbKeySpace And _
            KeyAscii_Code_nach_aktueller_Position <> 13 _
            And KeyAscii_Code_vor_aktueller_Position <> 13 Then
            'KeyAscii = 13
            SendKeys "{ENTER}", True
    End If


End Sub


Private Function LineStart() As Long

' aus Tipp 0118  "Timer1_Timer() "

Dim LineAct&

    LineAct = SendMessage(RichTextBox1.hwnd, EM_LINEFROMCHAR, -1, 0&)

    LineStart = SendMessage(RichTextBox1.hwnd, EM_LINEINDEX, -1, LineAct)
    
End Function
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------

Archivierte Nutzerkommentare 

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