This is an old revision of the document!
Eine Sammlung von Funktionen die ich mehrheitlich in VBA MS Access verwende. Sie sollten aber auch in anderen VBA-Scripten funktionieren. Getestet hab ich dies allerdings nicht. Für die Access-Spezifischen Funktionen gibts eine eigene Seite ([VBA] [Access] Functions) und auch für Arrays habe ich eine Sammlung ([VBA] Array Functions).
die Sammlung ist auch für mich, damit ich in verschiedenen Projekten auf meine Funktionen Zugriff habe. Darum ist auch nicht alles Dokumentiert und nicht jede Funktion macht per se Sinn.
Die Funktionen auf dieser Seite werden laufend in eigene Seiten, zusammen mit genaueren Beschreibungen und Beispielen, ausgelagert
Ist vor allem in Queries sehr angenehm, um mehrere Felder zu einem String zu kombinieren
'/** ' * Fügt mehrere Elemente zu einem String zusammen ' * @param ParamArray Die verschiedenen Elemente ' * @return String ' */ Public Function concat(ParamArray items() As Variant) As String concat = Join(items, Empty) End Function
Mehrere Replace auf einmal ausführen
'/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/index#replacea ' * ' * @example: str = replaceA("abcd", array("a", "c"), "_") '_b_d ' * @example: str = replaceA("abcd", array("a", "c"), array("A", "C") 'AbCd ' * ' * @example: str = replaceA("abcd", array("a", "c"), "_") '_b_d ' * @example: str = replaceA("abcd", array("a", "c"), array("A", "C") 'AbCd ' * @param Variant expression containing substring to replace. ' * @param Array<String> find Required. Substring being searched for. ' * @param Array<String> or String replace Required. Replacement substring. ' * @param Long Siehe VB-Doku zu replace() ' * @param Long Siehe VB-Doku zu replace() ' * @param VbCompareMethod Siehe VB-Doku zu replace() ' * 2return String ' */ Private Function replaceA( _ ByVal iExpression As Variant, _ ByVal iFind As Variant, _ ByVal iReplace As Variant, _ Optional ByVal iStart As Long = 1, _ Optional ByVal iCount As Long = -1, _ Optional ByVal iCompare As VbCompareMethod = vbBinaryCompare _ ) As String 'Sicherstellen, dass wir einen String haben Dim str As String: str = CStr(Nz(iExpression)) 'Sicherstellen, dass filnd ein Array as iFind ist Dim find As Variant: find = IIf(IsArray(iFind), iFind, Array(iFind)) 'Sicherstellen, dass repl ein Array aus iReplace ist Dim repl As Variant: repl = IIf(IsArray(iReplace), iReplace, Array(iReplace)) Dim i As Integer 'Die Arrays miteinander abstimmen. Wenn find mehr einträge als repl hat, so 'wird der Rest bei repl mit seinem letzten Eintrag aufgefüllt. For i = UBound(repl) + 1 To UBound(find) ReDim Preserve repl(i) repl(i) = repl(0) Next i 'Pro find ein Replace ausführen For i = 0 To UBound(find) str = replace(str, CStr(find(i)), CStr(repl(i)), iStart, iCount, iCompare) Next i 'return replaceA = str End Function
Entfern bei einem Zeitstempel Zeit:
01.12.2013 13:45:13
→ 01.12.2013
'/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * Schneidet die Zeit ab ' * @param Date Datum + Zeit ' * @retrun Date Datum ohne Zeit ' */ Public Function truncDate(Optional ByVal iDateTime As Variant = Null) As Date iDateTime = CDate(Nz(iDateTime, Now)) truncDate = DateSerial(Year(iDateTime), Month(iDateTime), Day(iDateTime)) End Function
Analog zu isNumeric(). Checkt ob ein Wert ein Byte ist
'/** ' * Copyright mpl by ERB software ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/index#isbyte ' * ' * Prüft on ein Value ein Byte-Wert ist ' * @param Variant Zu prüfender Wert ' * @return Boolean ' */ Public Function isByte(ByVal iExpression As Variant) As Boolean If Not IsNumeric(iExpression) Then Exit Function If iExpression < 0 Or 255 < iExpression Then Exit Function isByte = (CByte(iExpression) = iExpression) End Function
Analog zu isNumeric(). Checkt ob ein Wert ein Integer ist
'/** ' * Copyright mpl by ERB software ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/index#isinteger ' * ' * Prüft on ein Value ein Integer-Wert ist ' * @param Variant Zu prüfender Wert ' * @param Boolean Angabe, ob Byte auch als Integer gelten (Byte: 0 bis 255) ' * @return Boolean ' */ Public Function isInteger(ByVal iExpression As Variant, Optional ByVal iWithByte As Boolean = False) As Boolean If Not IsNumeric(iExpression) Then Exit Function If iExpression < -32768 Or 32767 < iExpression Then Exit Function isInteger = (CInt(iExpression) = iExpression) If Not iWithByte And isInteger Then isInteger = Not isByte(iExpression) End Function
Analog zu isNumeric(). Checkt ob ein Wert ein Longist
'/** ' * Copyright mpl by ERB software ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/index#islong ' * ' * Prüft on ein Value ein Long-Wert ist ' * @param Variant Zu prüfender Wert ' * @param Boolean Angabe, ob Integer/Byte auch als Long gelten (Integer: -32768 bis 32767) ' * @return Boolean ' */ Public Function isLong(ByVal iExpression As Variant, Optional ByVal iWithInteger As Boolean = False) As Boolean If Not IsNumeric(iExpression) Then Exit Function If iExpression < -2147483648# Or 2147483647 < iExpression Then Exit Function isLong = (CLng(iExpression) = iExpression) If Not iWithInteger And isLong Then isLong = Not isInteger(iExpression) End Function
Analog zu isNumeric().Checkt ob ein Wert ein Double ist
'/** ' * Copyright mpl by ERB software ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/index#isdouble ' * ' * Prüft on ein Value ein Double-Wert ist ' * @param Variant Zu prüfender Wert ' * @param Boolean Flag ob ein Integer/Long als Double akzeptiert werden soll ' * @return Boolean ' */ Public Function isDouble(ByVal iExpression As Variant, Optional ByVal iWithIntLng As Boolean = False) As Boolean If Not IsNumeric(iExpression) Then Exit Function isDouble = (CDbl(iExpression) = iExpression) If Not iWithIntLng And isDouble Then isDouble = Not isLong(iExpression, True) End Function
Und noch eine Prüfung ob ein Objekt eine Instanz eines Klasssenmoduls ist
'/** ' * Prüft ob das Objekt von einer User Definirten Klasse stammt ' * @param Variant Das zu untersuchende Objekt ' * @return Boolean True => Objekt ist ein Klassenmodul ' */ Private Function isClassModul(ByVal iExpression As Variant) As Boolean Dim tn As String: tn = typeName(iExpression) isClassModul = False On Error Resume Next isClassModul = (Application.VBE.ActiveVBProject.VBComponents(tn).name) = tn Err.Clear End Function
MS Access kennt für SQL-Statements kein Bit Vergleich. Mittels dieser Funktion kann man das im SQL trotzdem anwenden. Die Funktion kann aber auch normal innerhalb von VB verwednet werden.
'/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * Bit Comparison ' * geeignet für MS Access SQL-Statements ' * @example: Alle User mit Schreibrecheten gem. CHMOD hat ' * SELECT * FROM [user] WHERE BITCOMP([rigths], 2) ' * @param Integer ' * @param Integer ' * @return Boolean ' */ Public Function bitComp(ByVal iBytes As Integer, ByVal iBit As Integer) As Boolean bitComp = (iBytes And iBit) End Function
Analog zu max(). Jedoch mit mehreren Werten
'/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * Gibt den Grössten aus einer unbestimmten Menge von Werten zurück ' * @param Keine Objekte ' * @return Grösster Wert ' * @example greatest("Hallo Welt", 42, "Mister-X") -> Mister-X '*/ Public Function greatest(ParamArray items() As Variant) As Variant Dim item As Variant For Each item In items If item > greatest Then greatest = item Next item End Function
Analog zu min(). Jedoch mit mehreren Werten
'/** ' * Gibt den Kleinsten aus einer unbestimmten Menge von Werten zurück ' * @param Keine Objekte ' * @return Grösster Wert ' * @example least("Hallo Welt", 42, "Mister-X") -> 42 '*/ Public Function least(ParamArray items() As Variant) As Variant Dim item As Variant least = items(LBound(items)) For Each item In items If item < least Then least = item Next item End Function
'/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * Gibt den Höheren von 2 Werten zurück ' * @param Variant Wert 1 ' * @param Variant Wert 2 ' * @return Variant der Grössere Wert ' */ Public Function getMax(ByVal iValue1 As Variant, ByVal iValue2 As Variant) As Variant If iValue1 > iValue2 Then getMax= iValue1 Else getMax= iValue2 End If End Function
'/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * Gibt den Tieferen von 2 Werten zurück ' * @param Variant Wert 1 ' * @param Variant Wert 2 ' * @return Variant der Kleinere Wert ' */ Public Function getMin(ByVal iValue1 As Variant, ByVal iValue2 As Variant) As Variant If iValue1 < iValue2 Then getMin= iValue1 Else getMin= iValue2 End If End Function
'/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * Splittet ein Feld in Einzelteile und gibt dann den entsprechenden Wert zurück ' * Ist sehr gut geeignet um aus Queries zuzugreifen ' * ' * @example: "cdef" = chooseTextPart(1, "ab cdef gh j klm") ' * ' * @param Int Index Wert der gewählt werden soll. Index beginnt mit 0 ' * @param String Text Text der gesplittet werden soll ' * @param String delemiter Trennzeichen um den Text zu splitten ' * @return String Extrahiert Teil ' */ Public Function chooseTextPart(ByVal index As Integer, ByVal text As String, Optional ByVal delemiter As String = " ") As String parts = Split(text, delemiter) If (index <= UBound(parts)) Then chooseTextPart = parts(index) Else chooseTextPart = vbNullString End If End Function
'/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * gibt den ersten Eintrag der nicht NULL ist zurück. ' * Ist sehr gut geeignet um aus Queries zuzugreiffen ' * Die Funktion funktioniert auch mit Objekten ' * @return Variant ' * @example: ' * ?firstValue(null, null,13,14, null) //Rückgabewert 13 ' */ Public Function firstValue(ParamArray items() As Variant) As Variant For Each firstValue In items If Not IsNull(firstValue) Then Exit For Next End Function
Analog zu MySQL FIND_IN_SET(). Kann in Access vor allem bei nichtnormalisierten Tabellen verwendet werden
'/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * Analog zu MySQL FIND_IN_SET() ' * Kann in Access vor allem bei nichtnormalisierten Tabellen verwendet werden ' * @param String Element das gesucht wird ' * @param String Das Set von Elementen, mit Komma getrennt ' * @return Integer oder False ' * @example If find_in_set("d", "a,b,c,d") Then ... ' * @example SELECT ... WEHRE find_in_set('d', field1) ' */ Public Function find_in_set(ByVal iSearch As String, ByVal iSet As String) As Variant Dim parts() As String Dim index As Integer On Error GoTo Err_Handler find_in_set = False parts = split(iSet, ",") For index = 0 To UBound(parts) If Trim(parts(index)) = iSearch Then find_in_set = index + 1 Exit For End If Next index Exit Function Err_Handler: find_in_set = False End Function
'/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * überprüft ob eine Variable abgefüllt ist. "" wird als Nicht abgefüllt gewertet ' * sehr praktisch um innerhalb eines Query einen Wert zu prüfen ' * @param Variant Variable ' * @return Boolean ' */ Public Function isVoid(ByVal iVariable As Variant) As Boolean If IsObject(iVariable) Then isVoid = Not CBool(iVariable Is Nothing) Else isVoid = Not CBool(IsNull(iVariable) Or iVariable = vbNullString) End If End Function
'/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * Ersetzt alle Umlaute durch Xe ' * Idee by http://www.office-loesung.de/ftopic142553_0_0_asc.php ' * @param String Text in dem die Umlaute ersetzt werden soll ' * @param Boolean Flag ob bei Grossbuchstaben der Ersatzwert vollständig in Grossbuchstaben geandelt werden soll. Default: false ' * False: Ä -> Ae True: Ä -> AE ' * @return String ' */ Public Function replaceUmlaute(ByVal iSubject As String, Optional ByVal iCaseSave As Boolean = False) As String replaceUmlaute = iSubject replaceUmlaute = replace(replaceUmlaute, "Ä", IIf(iCaseSave, "AE", "Ae"), 1, -1, vbBinaryCompare) replaceUmlaute = replace(replaceUmlaute, "Ü", IIf(iCaseSave, "UE", "Ue"), 1, -1, vbBinaryCompare) replaceUmlaute = replace(replaceUmlaute, "Ö", IIf(iCaseSave, "OE", "Oe"), 1, -1, vbBinaryCompare) replaceUmlaute = replace(replaceUmlaute, "ä", "ae", 1, -1, vbBinaryCompare) replaceUmlaute = replace(replaceUmlaute, "ü", "ue", 1, -1, vbBinaryCompare) replaceUmlaute = replace(replaceUmlaute, "ö", "oe", 1, -1, vbBinaryCompare) replaceUmlaute = replace(replaceUmlaute, "ß", "ss", 1, -1, vbBinaryCompare) End Function