functions.bas

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.

Ist vor allem in Queries sehr angenehm, um mehrere Felder zu einem String zu kombinieren

concat.bas

'/**
' * 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

replacea.bas

'/**
' * 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

truncDate.bas

'/**
' * 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

isByte.bas

'/**
' * 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

isInteger.bas

'/**
' * 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

isLong.bas

'/**
' * 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

isDouble.bas

'/**
' * 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

isClassModul.bas

'/**
' * 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.

bitComp.bas

'/**
' * 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

greatest.bas

'/**
' * 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
'*/
Private Function greatest(ParamArray iItems() As Variant) As Variant
    greatest = iItems(UBound(iItems))
    Dim item As Variant: For Each item In iItems
        If Nz(item) > Nz(greatest) Then greatest = item
    Next item
End Function

Analog zu min(). Jedoch mit mehreren Werten

least.bas

'/**
' * 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
'*/
Private Function least(ParamArray iItems() As Variant) As Variant
    least = iItems(LBound(iItems))
    Dim item As Variant: For Each item In iItems
        If Nz(item) < Nz(least) Then least = item
    Next item
End Function

getMax.bas

'/**
' * 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

getMin.bas

'/**
' * 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

chooseTextPart.bas

'/**
' * 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

firstValue.bas

'/**
' * 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

find_in_set.bas

'/**
' * 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

isVoid.bas

'/**
' * 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

replaceUmlaute.bas

'/**
' * 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