VBA Tipp: Translate-Funktion

Aus DBWiki
Wechseln zu: Navigation, Suche

Anforderung

Eine translate()-Funktion existiert auf vielen Datenbank-Servern und vermeidet verschachteltete Aufrufe einer Replace()-Funktion.

Translate() wird verwendet, um jedes Zeichen in der Ausgangszeichenkette Source durch ein korrespondierendes Zeichen in ReplaceString zu übersetzen. Die Zeichen in ReplaceString entsprechen den Zeichen in MatchingString. Die Übersetzung erfolgt, wenn ein beliebiges Zeichen in der Zeichenkette mit dem Zeichen in der Zeichenkette MatchingString übereinstimmt. Ist an derselben Position in MatchingString kein Zeichen vorhanden, wird das Zeichen im Ergebnis ausgelassen.

Lösung

Die Funktion wird in einem allgemeinen VBA-Modul hinterlegt.

Reine VBA-Umsetzung

Diese Version kann mit wenigen Anpassungen auch in VBS verwendet werden.

Public Function Translate(Source As Variant, MatchingString As String, _
                          Optional ReplaceString As String) As Variant
 
   'Quelle: http://www.dbwiki.net/
 
   Const ERROR_TYPE_MISMATCH As Long = 13
 
   Dim ResultString   As String
   Dim SourceLength   As Long
   Dim MatchingLength As Long
   Dim ReplaceLength  As Long
   Dim Offset         As Long
   Dim Position       As Long
   Dim i              As Long
 
   If IsNull(Source) Then
      Translate = Null
      Exit Function
   End If
 
   If VarType(Source) <> vbString Then
      Translate = Error(ERROR_TYPE_MISMATCH)
      Exit Function
   End If
 
   SourceLength = Len(Source)
   'Speichplatz für das Ergebnis anfordern
   ResultString = Space$(SourceLength)
 
   MatchingLength = Len(MatchingString)
   ReplaceLength = Len(ReplaceString)
 
   For i = 1 To SourceLength
      'Für ein Zeichen in <Source> prüfen, ob es in <MatchingString> enthalten ist.
      Position = InStr(MatchingString, Mid(Source, i, 1))
      If Position > 0 Then
         'wurde das Zeichen in <MatchingString> gefunden
         If Position <= ReplaceLength Then
            'gibt es ein korrespondierendes Ersetzungszeichen in <ReplaceString>,
            'welches in die Position in <ResultString> eingetragen wird.
            Mid$(ResultString, i - Offset, 1) = Mid$(ReplaceString, Position, 1)
         Else
            'ist kein Ersatzzeichen vorhanden und wir zählen <Offset> um 1 hoch.
            Offset = Offset + 1
         End If
      Else
         'Zeichen aus <Source> in <ResultString> eintragen
         Mid$(ResultString, i - Offset, 1) = Mid(Source, i, 1)
      End If
   Next
 
   'ggf. Längenkorrektur am Ergenis vornehmen
   If Offset > 0 Then
      Translate = Left$(ResultString, SourceLength - Offset)
   Else
      Translate = ResultString
   End If
End Function

Optimierte Version mittels API-Unterstützung

Diese Version ist auf Schnelligkeit getrimmt.

Option Explicit
 
Public Type SafeArray1D
   cDims      As Integer
   fFeatures  As Integer
   cbElements As Long
   cLocks     As Long
   pvData     As Long
   cElements  As Long
   lLbound    As Long
End Type
 
'-------------------------------------------------------------------------------
Public Declare Sub RtlMoveMemory Lib "ntdll" ( _
   ByRef Destination As Any, _
   ByRef Source As Any, _
   ByVal Length As Long)
'-------------------------------------------------------------------------------
Private Declare Sub RtlZeroMemory Lib "ntdll" ( _
    dst As Any, _
    ByVal nBytes As Long)
'-------------------------------------------------------------------------------
Private Declare Function SysAllocString Lib "oleaut32" ( _
   ByVal psz As Long) As Long
'-------------------------------------------------------------------------------
 
'-------------------------------------------------------------------------------
#If VBA6 Then
'-------------------------------------------------------------------------------
Public Declare Function VarPtrArray Lib "vbe6.dll" _
   Alias "VarPtr" ( _
   Var() As Any) As Long
'-------------------------------------------------------------------------------
#Else
'-------------------------------------------------------------------------------
Public Declare Function VarPtrArray Lib "vbe7.dll" _
   Alias "VarPtr" ( _
   Var() As Any) As Long
#End If
'-------------------------------------------------------------------------------
 
Public Function Translate(Source As Variant, MatchingString As String, _
                          Optional ReplaceString As String) As Variant
 
   'Quelle: http://www.dbwiki.net/
 
   Const ERROR_TYPE_MISMATCH As Long = 13
 
   Dim ResultArray()   As Integer
 
   Dim SourceArray()   As Integer
   Dim SourceLength    As Long
   Dim pSourceArray    As Long
   Dim saSource        As SafeArray1D
 
   Dim MatchingArray() As Integer
   Dim MatchingLength  As Long
   Dim pMatchingArray  As Long
   Dim saMatching      As SafeArray1D
 
   Dim ReplaceArray()  As Integer
   Dim ReplaceLength   As Long
   Dim pReplaceArray   As Long
   Dim saReplace       As SafeArray1D
 
   Dim pv              As Long
 
   Dim Offset          As Long
   Dim i               As Long
   Dim j               As Long
 
   If IsNull(Source) Then
      Translate = Null
      Exit Function
   End If
 
   'Wir akzeptieren nur Strings in <Source>
   If VarType(Source) <> vbString Then
      Translate = Error(ERROR_TYPE_MISMATCH)
      Exit Function
   End If
 
   MatchingLength = Len(MatchingString)
   If MatchingLength = 0 Then
      'gibt es nichts zu tun
      Translate = Source
      Exit Function
   End If
 
   SourceLength = Len(Source)
   If SourceLength = 0 Then
      'gibt es nichts zu tun
      Translate = Source
      Exit Function
   End If
 
   '<Source> auf Integer Array <SourceArray> mappen
   pSourceArray = VarPtrArray(SourceArray)
   With saSource
      .cDims = 1                 'eindimensional
      .cbElements = 2            '2 Bytes sind in einem Integer
      .pvData = StrPtr(Source)   'Zeiger auf die String-Daten
      .cElements = SourceLength  'Anzahl Elemente
   End With
   'Zeiger auf SafeArray eintragen
   RtlMoveMemory ByVal pSourceArray, VarPtr(saSource), 4
 
   '<MatchingString> auf Integer Array <MatchingArray> mappen
   pMatchingArray = VarPtrArray(MatchingArray)
   With saMatching
      .cDims = 1
      .cbElements = 2
      .pvData = StrPtr(MatchingString)
      .cElements = MatchingLength
   End With
   RtlMoveMemory ByVal pMatchingArray, VarPtr(saMatching), 4
 
   ReplaceLength = Len(ReplaceString)
   If ReplaceLength > 0 Then
      'nur wenn ReplaceString Daten aufweist
      '<ReplaceString> auf Integer Array <ReplaceArray> mappen.
      pReplaceArray = VarPtrArray(ReplaceArray)
      With saReplace
         .cDims = 1
         .cbElements = 2
         .pvData = StrPtr(ReplaceString)
         .cElements = ReplaceLength
      End With
      RtlMoveMemory ByVal pReplaceArray, VarPtr(saReplace), 4
   End If
 
   'Hier tragen wir das Ergebnis ein.
   'berücksichtigt eine abschließende 0 am Ende für <SysAllocString()>
   ReDim ResultArray(SourceLength)
 
   For i = 0 To SourceLength - 1
      'Für jedes Zeichen zwischen &H0000..&HFFFF in <Source>
      For j = 0 To MatchingLength - 1
         '... prüfen, ob es in <MatchingString> enthalten ist
         If SourceArray(i) = MatchingArray(j) Then Exit For
      Next
 
      If j < MatchingLength Then
         'wurde das Zeichen aus <Source> in <MatchingString> gefunden
         If j < ReplaceLength Then
            'existiert ein Ersetzungzeichen an gleicher Position in <ReplaceString>,
            'übernehmen wir es in das Ergebnis.
            ResultArray(i - Offset) = ReplaceArray(j)
         Else
            'Wenn kein Ersetzungszeichen in <ReplaceString> vorhanden ist, wird
            'das Zeichen übersprungen. In Offset merken wir uns die Anzahl
            'ausgelassener Zeichen
            Offset = Offset + 1
         End If
      Else
         'Zeichen aus <Source> in <ResultArray> übernehmen
         ResultArray(i - Offset) = SourceArray(i)
      End If
   Next
 
   'Zeiger auf Funktionsergebis holen.
   pv = VarPtr(Translate)
   'Das Ergebnis als String kennzeichnen.
   RtlMoveMemory ByVal pv, vbString, 2
   'Aus <ResultArray> einen neuen String erstellen und in als Rückgabe
   'an die entsprechende Speicherposition schreiben.
   RtlMoveMemory ByVal pv + 8, SysAllocString(VarPtr(ResultArray(0))), 4
 
   '!!! Wichtig !!!
   'alle gemappten Arrays auf 0 zurücksetzen, sonst stürzt VBA ab.
   If pReplaceArray Then RtlZeroMemory ByVal pReplaceArray, 4
   RtlZeroMemory ByVal pMatchingArray, 4
   RtlZeroMemory ByVal pSourceArray, 4
End Function

Aufruf

im Direktfenster

?Translate("das ist ein string", "abcdefghijklmnopqrstubwxyz", "defghijklmnopqrstubwxyzabc") 
gdb lbw hlq bwulqj
 
?Translate("+91 25-2469782464", "0123456789-+", "6789012345+-") 
-57 81+8025348020
 
?Translate("Complete IT Professional", " o", "_a")
Camplete_IT_Prafessianal
 
?Translate("Complete IT Professional", "Is", "SW")
Complete ST ProfeWWional
 
?Translate("Complete IT Professional", "IsC m", "SWx2q")
xoqplete2ST2ProfeWWional
 
?Translate("Complete IT Professional", "IsC m", "")
opleteTProfeional
 
?Translate("Complete IT Professional", "omsi", "12")
C12plete IT Pr1fe1nal
 
?Translate("2*[3+4]/{7-2}", "[]{}", "()()")
2*(3+4)/(7-2)

Weblinks