Eine Sammlung von Funktionen die ich mehrheitlich in VBA MS Access verwende. Siehe dazu auch noch meine allgemeinen Functions sowie die [VBA] Array Functions.

Eine Funktion um DAO.DateTypeEnum in die DDL-Syntax zu wandeln.

getSQLType

'/**
' * Gibt den SQL-Type für ein DAO.DataTypeEnum zurück.
' * Diesen kann man für automatisierte CRATE TABLE oder ALTER TABLE verwenden
' * @param  DAO.DataTypeEnum
' * @param  Integer
' * @return String
' */
Public Function getSQLType(ByVal iVarType As DAO.DataTypeEnum, Optional ByVal iSize As Integer = 50) As String
	Select Case iVarType
		Case dbText:        getSQLType = "TEXT(" & iSize & ")"
		Case dbLong:        getSQLType = "LONG"
		Case dbInteger:     getSQLType = "INTEGER"
		Case dbBoolean:     getSQLType = "YESNO"
		Case dbMemo:        getSQLType = "MEMO"
		Case dbByte:        getSQLType = "BYTE"
		Case dbSingle:      getSQLType = "SINGLE"
		Case dbCurrency:    getSQLType = "CURRENCY"
		Case dbTimeStamp:   getSQLType = "DATETIME"
		Case dbBinary:      getSQLType = "BINARY(" & iSize & ")"
		Case dbLongBinary:  getSQLType = "LONGBINARY"
		Case Else:          getSQLType = "TEXT(" & iSize & ")"
	End Select
End Function

createIncrementField

'/**
' * erstellt ein Auto-Feld in einer Tabelle
' * @param  String  Tabellenname
' * @param  String  Feldname
' */
Public Sub createIncrementField(ByVal tableName As String, Optional ByVal FieldName As String = "id")
	Dim fld         As field
On Error GoTo Err_Handler
 
	Set fld = CurrentDb.TableDefs(tableName).CreateField(FieldName, dbLong)
	fld.Attributes = dbAutoIncrField
	Call CurrentDb.TableDefs(tableName).fields.append(fld)
 
Exit_Handler:
	Set fld = Nothing
	Exit Sub	
Err_Handler:
	msgBox Err.DESCRIPTION
	GoTo Exit_Handler
	Resume
End Sub

resetIncrementField

'/**
' * Setzt den Wert einer AutoNumber Spalte zurück
' * @param  <String>            Name der Tabelle
' * @param  <String>            Name der Auto-Number Spalte
' */
Public Sub resetIncrementField(ByVal iTableName As String, ByVal iColName As String)
	Call CurrentDb.execute("ALTER TABLE [" & iTableName & "] ALTER COLUMN [" & iColName & "] COUNTER(1,1)")
End Sub

Eine Tabelle vollständig leeren

truncate

'/**
' * leert eine Tabelle
' * @param  String
' */
Public Sub truncate(ByVal tableName As String)
	Call CurrentDb.execute("DELETE FROM " & tableName)
End Sub

Häufig bekomme ich Tabellen im Excel-Format. Diese sind schnell importiert. Jedoch haben sie dann meistens irgendwelche netten und schön lesbare Spaltenüberschriften. Mit dieser Funktion kann ich alle Spaltennamen in technische Spaltennamen wandeln

translateTableFields

.
Diese Funktion verwendet die Funktion [[http://wiki.yaslaw.info/wikka/VbAccessFunctions#translateToTechName translateToTechName()]].
'/**
' * Wandelt alle Spaltennamen in technische Namen. Praktisch nach einem Erstimport aus Excel
' * @used               http://wiki.yaslaw.info/wikka/VbAccessFunctions#translateToTechName
' * @param  String      Tabellenname
' */
Public Sub translateTableFields(ByVal iTableName As String)
	Dim tbl     As DAO.TableDef
	Dim dbs     As DAO.Database
	Dim fld     As DAO.field
 
	Set dbs = CurrentDb
	Set tbl = dbs.TableDefs(iTableName)
 
	For Each fld In tbl.fields
		fld.name = translateToTechName(fld.name)
	Next
 
	Set fld = Nothing
	Set tbl = Nothing
	Set dbs = Nothing
End Sub

truncate

'/**
' * Überprüft ob ein bestimmtes Formular geöffnet (geladen) ist
' * @param  String      Name des Formulares
' * @return Boolean
' */
Public Function formIsLoaded(ByVal strFormName As String) As Boolean
	formIsLoaded = False
	If SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> 0 Then
		If Forms(strFormName).CurrentView <> 0 Then
			formIsLoaded = True
		End If
	End If
End Function

closeAllForms

'/**
' * Schliesst alle geladenen Formulare mit Ausnahmen
' * @param  AcCloseSave     iSave           Access-Type ob die Daten der Formulare gespeichert werden sollten
' * @param  Array<String>   iExceptions     Array mit den Namen der Formulare die nicht geschlossen werden sollen
' * @return void
' */
Public Function closeAllForms(Optional ByVal iSave As AcCloseSave = acSaveNo, Optional ByVal iExceptions As Variant)
	Dim pForm   As Form
 
	For Each pForm In Forms
		If IsArray(iExceptions) Then
			If ArrayIndex(pForm.name, iExceptions) < -1 Then Call DoCmd.Close(acForm, pForm.name, acSavePrompt)
		Else
			Call DoCmd.Close(acForm, pForm.name, acSavePrompt)
		End If
	Next pForm
 
End Function

cm2twips

'/**
' * Wandelt zu cm zu Twips
' * @param  Variant     cm  (Entweder ein Array von cm, oder ein einzelner
' * @return Variant     Twips (Entweder ein Array von Twips, oder ein einzelner
' */
Function cm2twips(ByVal iCm As Variant) As Variant
    Dim i           As Long
    Dim pArray()    As Variant
    Dim flagArray   As Boolean
On Error GoTo Err_Handler
 
    flagArray = IsArray(iCm)
 
    If Not flagArray Then iCm = Array(iCm)
    ReDim pArray(LBound(iCm) To UBound(iCm))
 
    For i = LBound(iCm) To UBound(iCm)
        pArray(i) = CLng(Fix(iCm(i) * 567))
    Next i
 
    cm2twips = IIf(flagArray, pArray, pArray(LBound(pArray)))
 
Exit_Handler:
    Exit Function
Err_Handler:
    cm2twips = Null
    GoTo Exit_Handler
    Resume
End Function

twips2cm

'/**
' * Wandelt Twips zu cm
' * @param  Variant     Twips (Entweder ein Array von Twips, oder ein einzelner
' * @retrun Variant     cm  (Entweder ein Array von cm, oder ein einzelner
' */
Function twips2cm(ByVal iTwips As Variant) As Variant
    Dim i           As Long
    Dim pArray()    As Variant
    Dim flagArray   As Boolean
On Error GoTo Err_Handler
 
    flagArray = IsArray(iTwips)
 
    If Not flagArray Then iTwips = Array(iTwips)
    ReDim pArray(LBound(iTwips) To UBound(iTwips))
 
    For i = LBound(iTwips) To UBound(iTwips)
        pArray(i) = CDbl(iTwips(i) / 567)
    Next i
 
    twips2cm = IIf(flagArray, pArray, pArray(LBound(pArray)))
 
Exit_Handler:
    Exit Function
Err_Handler:
    twips2cm = Null
    GoTo Exit_Handler
End Function

changeProperty

'/**
' * Ändert ein DB-Property
' * @param  String      Name des Property
' * @param  Variant     Type des Property
' *         (Wird nur verwendet, wenn das Property noch nicht exisitert. Weitere Infos unter CurrentDb.CreateProperty)
' * @param  Variant     Wert des Property
' * @return void
' */
Public Function changeProperty(ByVal iname As String, ByVal itype As Variant, ByVal iValue As Variant) As Boolean
	Const C_PORPERTY_NOT_FOUND = 3270
	Dim pProprty As Property
On Error GoTo Err_Handler
 
	CurrentDb.Properties(iname) = iValue
	ChangeProperty = True
 
Exit_Handler:
	Exit Function
Err_Handler:
	If Err = C_PORPERTY_NOT_FOUND Then  ' Property not found.
		Set pProprty = CurrentDb.CreateProperty(iname, itype, iValue)
		CurrentDb.Properties.append pProprty
		Resume Next
	Else
		ChangeProperty = False
		Resume Exit_Handler
	End If
End Function

Eine Funktion um zu überprüfen ob ein bestimmtes Objekt in der Acces DB exisitert. Dese Lösung basiert auf dem Try-and-Error Pattern.

objectExists

'/**
' * Prüft ob ein bestimmtest Access-Objekt existiert
' * @param  <AcObjectType>      Type vom Objekt
' * @param  <String>            Name des gesuchten Objektes
' * @retrun <Boolean>
' * @example    If ObjectExists(acQuery, "vw_temp") then CurrentDb.QueryDefs.Delete("vw_temp")
' */
Public Function objectExists(ByVal iObjectType As AcObjectType, ByVal iObjectName As String) As Boolean
	Dim dummy As Variant
On Error Resume Next
 
	'Je nach Type unterschiedlich prüfen
	Select Case iObjectType
		Case acTable:       Set dummy = CurrentDb.TableDefs(iObjectName)
		Case acQuery:       Set dummy = CurrentDb.QueryDefs(iObjectName)
		Case acForm:        Set dummy = CurrentProject.AllForms(iObjectName)
		Case acReport:      Set dummy = CurrentProject.AllReports(iObjectName)
		Case acModule:      Set dummy = CurrentProject.AllModules(iObjectName)
		Case acMacro:       Set dummy = CurrentProject.AllMacros(iObjectName)
		Case Else:          Err.Raise (-1)
	End Select
	'Wenn kein Fehler aufgetretten ist, exisitert das Objekt
	objectExists = (Err.Number = 0)
	Call dummy.Close
	Set dummy = Nothing
	Err.clear
End Function

Und falls man zusätzlich auf die Existenz einer Funktion prüfen möchte, diesen Case noch hinzufügen

		' Für desen Teil braucht es eine Referenz auf 'Microsoft Visual Basic for Applications Extensibility'
		Case acFunction:
			Dim cp As CodePane			
			For Each cp In VBE.CodePanes
				Err.clear
				dummy = cp.CodeModule.ProcStartLine(iObjectName, vbext_pk_Proc)
				If Err.Number = 0 Then Exit For
			Next		
			Set cp = Nothing