Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0596: Undo/Redo Funktion realisieren

VB 5/6-Tipp 0596: Undo/Redo Funktion realisieren

 von Andreas Pickmann

Schwierigkeitsgrad:

Verwendete API-Aufrufe: DrawTextA (DrawText), GetCaretPos, SendMessageA (SendMessage)

Download: Download des Beispielprojektes [6,16 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 Windows Common Controls 6.0 (SP6) (mscomctl.ocx)' wird benötigt.

'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Listen-Steuerelement "lstundo"
' Steuerelement: Bilderlistenelement "ImageList1"
' Steuerelement: Toolbar "Toolbar1"
' Steuerelement: Listen-Steuerelement "lstredo"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: RichTextBox "RTB"

'Autor: Andreas Pickmann

Option Explicit

Dim Key_down As Long, K_Shift As Long, Sel As String

Private Sub Form_Load()
    Call Index_loeschen
End Sub

Private Sub Command1_Click()
    Unload Me
End Sub

Private Sub lstredo_LostFocus()
    lstredo.Visible = False
End Sub

Private Sub lstundo_LostFocus()
    lstundo.Visible = False
End Sub

' ******************************************************************************
' *************************** Richtextbox - Ereignisse *************************
' ******************************************************************************

Private Sub RTB_KeyDown(KeyCode As Integer, Shift As Integer)
' Abfangen der gedrückten Taste
    Key_down& = KeyCode
    K_Shift& = Shift
    Sel$ = RTB.SelText
End Sub

Private Sub RTB_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Call Undo_set_data(10000, 0, "")
End Sub

Private Sub RTB_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Call Undo_set_data(10001, 0, "")
End Sub
Private Sub RTB_SelChange()
    If Key_down > -1 Then Call Undo_set_data(Key_down&, K_Shift&, Sel$)
    K_Shift& = -1
    Sel$ = ""
End Sub

' ******************************************************************************
' ************************ Toolbar - Ereignisse ********************************
' ******************************************************************************

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.Index
        Case 1 ' Undo
            ' das Neugeschriebene noch schnell sichern ...
            If Key_down > -1 Then Call Undo_set_data(10000, 0, 0)
            Call bef_ausfuehren(lstundo, lstredo, "undo")
        Case 2 ' Redo
            Call bef_ausfuehren(lstredo, lstundo, "redo")
    End Select
End Sub
Private Sub Toolbar1_ButtonDropDown(ByVal Button As MSComctlLib.Button)
    Select Case Button.Index
        Case 1 ' Undo
            ' das Neugeschriebene noch schnell sichern ...
            If Key_down > -1 Then Call Undo_set_data(10000, 0, 0)
            lstredo.Visible = False
            Call ListBox_starten(Form1.lstundo)
            Key_down& = -1
        Case 2 ' Redo
            lstundo.Visible = False
            Call ListBox_starten(Form1.lstredo)
    End Select
End Sub

' ******************************************************************************
' ************************ Listbox - Ereignisse ********************************
' ******************************************************************************
Private Sub lstundo_Click()
    Dim i&
    If Toolbar1.Buttons.Item(2).Enabled = False Then lstredo.Clear
    ' If Key_down& > -1 Then Call Undo_set_data(10000, 0, 0)
    For i = 0 To lstundo.ListIndex
        Call bef_ausfuehren(lstundo, lstredo, "undo")
    Next i
End Sub

Private Sub lstredo_Click()
    Dim i&
    For i = 0 To lstredo.ListIndex
        Call bef_ausfuehren(lstredo, lstundo, "redo")
    Next i
End Sub

Private Sub bef_ausfuehren(von As Object, nach As Object, bef$)
    If bef = "undo" Then Call undo
    If bef = "redo" Then Call redo
    ' hier werden die Schritte in der Gegenfunktionsliste
    ' wieder verfügbar gemacht
    nach.AddItem von.List(0), 0
    von.RemoveItem (0)
    von.Visible = False
    nach.Visible = False
    Key_down& = -1
    K_Shift& = -1
    Sel$ = ""
    ' die neue Position im Text erfassen ( static Variable "old_pos" )
    Call Undo_set_data(10001, 0, 0)
End Sub



'---------- Ende Formular "Form1" alias Form1.frm  ----------
'------- Anfang Modul "Undo_func" alias Undo_func.bas -------

Option Explicit

Private Declare Function SendMessage Lib "user32" Alias _
        "SendMessageA" (ByVal hwnd As Long, ByVal wMsg _
        As Long, ByVal wParam As Long, ByVal lParam As _
        String) As Long
        
Private Declare Function GetCaretPos Lib "user32" _
        (lpPoint As POINTAPI) As Long

Private Declare Function DrawText Lib "user32" Alias _
        "DrawTextA" (ByVal hdc As Long, ByVal lpStr As _
        String, ByVal nCount As Long, lpRect As RECT, _
        ByVal wFormat As Long) As Long
        
Private Type POINTAPI
  x As Long
  y As Long
End Type

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

Const DT_CALCRECT = &H400
Const LB_FINDSTRING = &H18F
Const SP = 3&

Dim uText() As String
Dim uPos() As Long
Dim uStart() As Long
Dim uLen() As Long
Dim ubef() As Long


Public Sub redo()
    Dim pos As Long, c As Long
    
    c& = Form1.lstundo.ListCount
    
    If ubef(c) = 0 Then
        ' Text wird eingefügt
        If uStart(c) > 1 Then
            Form1.RTB.SelStart = uStart(c)
        Else
            Form1.RTB.SelStart = uStart(c) + 1
        End If
        
        Form1.RTB.SelText = uText(c)
        
    ElseIf ubef(c) = 1 Then
        ' Text wird gelöscht
        pos = Form1.RTB.Find(uText(c), uStart&(c), , 0)
        If pos > -1 Then Form1.RTB.SelText = ""
    End If
    
    ' Wenn letzter Eintrag in der Liste erreicht ist,
    ' dektiviere den Redo-Button
    If Form1.lstredo.ListCount = 1 Then Call button_deaktivieren(1)
    
    ' Undo Button Aktivieren
    Call button_aktivieren(2)
End Sub

Public Sub undo()
    Dim pos As Long, c As Long
    
    c = Form1.lstundo.ListCount + Form1.lstredo.ListCount - _
        (Form1.lstredo.ListCount + 1)
        
    If ubef(c) = 0 Then
        ' Text wird gelöscht
        pos& = Form1.RTB.Find(uText(c), uPos(c) - uLen&(c), , 0)
        If pos > -1 Then Form1.RTB.SelText = ""
        
    ElseIf ubef(c) = 1 Then
        ' Text wird eingefügt
        Form1.RTB.SelStart = uStart(c)
        Form1.RTB.SelText = uText(c)
    End If
    
    ' Wenn letzter Eintrag in der Liste erreicht ist, daktiviere den Undo-Button
    If Form1.lstundo.ListCount = 1 Then Call button_deaktivieren(2)
    
    ' Redo Button Aktivieren
    Call button_aktivieren(1)
End Sub


Public Sub Undo_set_data(KC As Long, S As Long, Sel As String)
  Dim Text As String
  Dim uLendth As Long
  Dim us As Long
  Dim art As Long
  Dim Part As String
  Dim KCode As Long
  Dim Bez As String
  Dim doit As Boolean
  Dim newpos As Long
  Dim temp As String
  Dim test As Long
  Dim c As Long
  
  Static oldpos As Long
  Static oldtext As String
  
  ' der einfachheit halber
  KCode = S * 1000 + KC
  art = -1
  Bez$ = Bezeichnung(KCode)
  Select Case KCode&
      Case 2086, 13, 10000
          newpos = Form1.RTB.SelStart
          If newpos <> oldpos Then
              art = 0
                If newpos >= oldpos Then
                  us = oldpos
                  uLendth& = newpos - oldpos
                  Text$ = Form1.RTB.Text
                End If
              If us >= 0 Then Part$ = Mid$(Text$, us + 1, uLendth&)
              oldpos& = newpos
          End If
      Case 46, 8, 2088
          If Sel$ <> "" Then
              art = 1
              If oldpos > 0 Then oldpos = oldpos - 1 Else oldpos = 0
              us = oldpos
              uLendth& = Len(Sel$)
              Part$ = Sel$
          End If
      Case 10001
          newpos = Form1.RTB.SelStart
          oldpos& = newpos
  End Select
  
  If art > -1 And Part$ <> "" Then
      ' Eintrag für die Listbox "stutzen" und eventuell
      ' den Zeilenumbruch abschneiden
          If Len(Part$) > 15 Then Text$ = ".." & _
              Right$(Part$, 15) Else Text$ = Part$
          If KCode = 13 Then Text$ = Left$(Text$, Len(Text$) - 2)
          
      ' Eintrag in die Liste
          Form1.lstundo.AddItem Bez$ & " " & """" & Text$ & """", 0
          
      ' Die restliche relevanten Daten in den Variablen speichern
      ' dieser Teil ist sicherlich noch verbesserungsfähig
          c& = Form1.lstundo.ListCount - 1
          ReDim Preserve uText$(c), uPos&(c), ubef(c)
          ReDim Preserve uStart&(c), uLen&(c)
          uText(c) = Part
          uPos(c) = newpos
          uStart(c) = us
          uLen(c) = uLendth
          ubef(c) = art
          
      ' Da etwas neues geschrieben wurde, wird der redo-Button deaktiviert
      ' und der Undo-Button aktiviert
          Call button_aktivieren(2)
          Call button_deaktivieren(1)
  End If
  oldtext = Form1.RTB.Text
End Sub

Public Sub button_deaktivieren(num&)
  If num = 1 Or num = 3 Then
      ' redo
      Form1.Toolbar1.Buttons.Item(2).Enabled = False
      Form1.Toolbar1.Buttons.Item(2).Image = 4
  End If
  
  If num = 2 Or num = 3 Then
      ' undo
      Form1.Toolbar1.Buttons.Item(1).Enabled = False
      Form1.Toolbar1.Buttons.Item(1).Image = 3
  End If
End Sub

Public Sub button_aktivieren(num&)
  If num = 1 Or num = 3 Then
      ' redo
      Form1.Toolbar1.Buttons.Item(2).Enabled = True
      Form1.Toolbar1.Buttons.Item(2).Image = 2
  End If
  If num = 2 Or num = 3 Then
      ' undo
      Form1.Toolbar1.Buttons.Item(1).Enabled = True
      Form1.Toolbar1.Buttons.Item(1).Image = 1
  End If
End Sub

Public Sub Index_loeschen()
    Form1.lstundo.Clear
    Form1.lstredo.Clear
    ReDim uText(0), uPos(0), ubef(0)
    ReDim uStart(0), uLen(0)
    Call button_deaktivieren(3)
End Sub

Private Function Bezeichnung(num As Long) As String
  Dim temp As String
  Select Case num
      Case 13, 10000
          temp = "Eingabe:"
      Case 2088
          temp = "Ausschneiden:"
      Case 2086
          temp = "Einfügen:"
      Case 46
          temp = "Löschen:"
  End Select
  Bezeichnung = temp
End Function

Public Sub ListBox_starten(obj As Object)
    Dim P As POINTAPI
    Dim hDcT As Long
    Dim r As RECT
    Dim x As Long
    Dim y As Long
    Dim x1 As Long
    Dim x2 As Long
    Dim aa As String
    Dim Lx As Long
    Dim Ly As Long
    Dim maxlen As String
    Dim bunt As String
    Dim norm As String
    
    maxlen = String$(30, "X")
    obj.Visible = True
    hDcT = obj.Parent.hdc
    Call DrawText(hDcT, maxlen, -1, r, DT_CALCRECT)
    obj.Width = r.Right * Screen.TwipsPerPixelX + 85
    Call GetCaretPos(P)
    
    Lx = Form1.Toolbar1.Left + (P.x + SP) * Screen.TwipsPerPixelX
    If Lx + obj.Width > Form1.Toolbar1.Width Then
        Lx = Form1.Toolbar1.Width - obj.Width
    End If
    
    Ly = Form1.Toolbar1.Top + (P.y + r.Bottom + SP) * _
         Screen.TwipsPerPixelY + Form1.Toolbar1.Height / 2

    If obj.ListCount < 6 Then obj.Height = 255 + (obj.ListCount - 1) _
        * 195 Else obj.Height = 1035
    
    obj.Left = Lx
    obj.Top = Ly
End Sub
'-------- Ende Modul "Undo_func" alias Undo_func.bas --------
'-------------- 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.