Startseite / Tipps / VB 5/6-Tipp 0572: Reguläre Ausdrücke in VB benutzen

VB 5/6-Tipp 0572: Reguläre Ausdrücke in VB benutzen

 von Dominik Auras

'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 Regulaere Ausdruecke.vbp -------
' Es muss ein Verweis auf 'Microsoft VBScript Regular Expressions 5.5' gesetzt werden.

'--- Anfang Formular "Form1" alias Regulaere Ausdruecke.frm ---
' Steuerelement: Textfeld "Text1"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Beschriftungsfeld "Label1"

'
'Autor: Dominik Auras - neo@tipsntricks.de
'       http://www.vbinside.de

Option Explicit

Private Declare Function GetTickCount Lib "kernel32" () As Long

Private Declare Function QueryPerformanceCounter Lib "kernel32" ( _
   lpPerformanceCount As LARGE_INTEGER) As Long
   
Private Declare Function QueryPerformanceFrequency Lib "kernel32" ( _
   lpFrequency As LARGE_INTEGER) As Long

Private Type LARGE_INTEGER
  lowpart As Long
  highpart As Long
End Type

Dim freq As LARGE_INTEGER, calibration As Double

Private Sub Command1_Click()
  Dim Content As String, i As Long, c As Long, e As Long
  Dim a As String, b As String, reRLE As New RegExp
  Dim colMatches As MatchCollection, reMatch As Match
  Dim Ret As String, OldC As String, OldRet As String
  Dim Start As LARGE_INTEGER, Ende As LARGE_INTEGER
  
    e = 100& * 1024&
  
    'Zufälligen Text erzeugen, der nachher komprimiert werden soll
    Randomize Timer
    Do While Len(Content) < e
      i = Rnd * 254 + 1
      If i > e - Len(Content) Then i = e - Len(Content)
      OldC = c
      Do
        c = Rnd * 255
      Loop Until OldC <> c
      
      Content = Content & String(i, c)
    Loop
    
    Debug.Print "Stringgröße: " & Len(Content)
    Text1.Text = Text1.Text & "Stringgröße: " & Len(Content) & vbCrLf
    
    QueryPerformanceCounter Start
    
    '#############
    'Komprimierung mit VB-Schleife (RLE-Algo)
    'API-Zeitmessung
    
    a = ""
    b = ""
    c = 0
    b = Mid$(Content, 1, 1)
    
    For i = 1 To Len(Content)
      a = Mid$(Content, i, 1)
      
      If b = a Then
        c = c + 1
      Else
        Ret = Ret & Chr$(c) & b
        b = a
        c = 1
      End If
    Next i
    Ret = Ret & Chr$(c) & b
    '#############
    QueryPerformanceCounter Ende
    
    Debug.Print "VB komprimiert " & Len(Ret) & ": ";
    Debug.Print Int(((CDouble(Ende) - CDouble(Start)) / _
                    CDouble(freq) * 1000 - calibration) * _
                    100000000000#) / 100000000000# & " ms"
                    
    Text1.Text = Text1.Text & "VB komprimiert " & Len(Ret) & ": " & _
                 Int(((CDouble(Ende) - CDouble(Start)) / _
                    CDouble(freq) * 1000 - calibration) * _
                    100000000000#) / 100000000000# & " ms" & vbCrLf
    
    OldRet = Ret
    Ret = ""
    
    QueryPerformanceCounter Start
    
    '#############
    'Derselbe Algorithmus zur Komprimierung nun mit einem
    'regulären Ausdruck
    '+ API-Zeitmessung
    
    reRLE.Pattern = "(.|\n|\r)\1*"
    reRLE.Global = True
    'das allseits bekannte /../g in Perl etc.
    
    Set colMatches = reRLE.Execute(Content)
    'RegEx anwenden und _alle_ Fundstellen speichern
    
    'Fundstelle durchgehen
    For i = 0 To colMatches.Count - 1
      Set reMatch = colMatches(i)
      Ret = Ret & Chr$(reMatch.Length) & reMatch.SubMatches(0)
    Next i
    '#############
    
    QueryPerformanceCounter Ende
    
    Debug.Print "RegEx komprimiert " & Len(Ret) & ": ";
    Debug.Print Int(((CDouble(Ende) - CDouble(Start)) / _
                    CDouble(freq) * 1000 - calibration) * _
                    100000000000#) / 100000000000# & " ms"
                    
    Text1.Text = Text1.Text & "RegEx komprimiert " & Len(Ret) & ": " & _
                 Int(((CDouble(Ende) - CDouble(Start)) / _
                    CDouble(freq) * 1000 - calibration) * _
                    100000000000#) / 100000000000# & " ms" & vbCrLf
                    
    'Kontrolle des RLE-Algortihmus
    If OldRet = Ret Then
      Debug.Print "Daten stimmen überein"
      Text1.Text = Text1.Text & "Daten stimmen überein" & vbCrLf
    End If
    
    For i = 1 To Len(Ret)
      If i > Len(OldRet) Then
        Debug.Print "pos", i, "char", Mid$(Ret, i, 1)
      Else
        If Mid$(Ret, i, 1) <> Mid$(OldRet, i, 1) Then
          Debug.Print "pos", i, "char", Mid$(Ret, i, 1)
        End If
      End If
    Next i
    
    Text1.Text = Text1.Text & "http://www.vbinside.de" & vbCrLf
End Sub

Private Function CDouble(Num As LARGE_INTEGER) As Double
  Dim Low As Double, High As Double
  
    Low = Num.lowpart
    High = Num.highpart
    
    If Low < 0 Then Low = 4294967296# + Low + 1
    If High < 0 Then High = 4294967296# + High + 1
    
    CDouble = Low + High * 4294967296#
End Function

Private Sub Form_Load()
  Dim Start As LARGE_INTEGER, Ende As LARGE_INTEGER
  
    QueryPerformanceFrequency freq
  
    QueryPerformanceCounter Start
    QueryPerformanceCounter Ende
    
    calibration = (CDouble(Ende) - CDouble(Start)) / _
                  CDouble(freq) * 1000
End Sub
'--- Ende Formular "Form1" alias Regulaere Ausdruecke.frm ---
'-------- Ende Projektdatei Regulaere Ausdruecke.vbp --------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

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