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

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

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