~~DISCUSSION:off~~
~~NOCACHE~~ 
<const>ns=%NAMESPACE%</const>
======[VBA] [Access] Functions======
Eine Sammlung von Funktionen die ich mehrheitlich in VBA MS Access verwende.
Siehe dazu auch noch meine allgemeinen [[:Vba:Functions:]] sowie die [[:Vba:Functions:array:]].


===== Funktionen mit eigener Seite =====
{{pagequery>
  ^%%ns%%:(?!index)[^:]+(?::index)?$;
  fullregex;
  sort=ns:asc,title:asc;
  display={title};
  snippet=plain,999999,l1;
  bullet=square;
  fontsize=100%;
  hidemsg;
  hidejump;
 }}

=====Rund um SQL=====
====getSQLType()====
Eine Funktion um <nowiki>DAO.DateTypeEnum</nowiki> in die DDL-Syntax zu wandeln.
<code vb 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
</code>


====createIncrementField()====
<code vb 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
</code>


====resetIncrementField()====
<code vb 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
</code>


====truncate()====
Eine Tabelle vollständig leeren
<code vb truncate>
'/**
' * leert eine Tabelle
' * @param  String
' */
Public Sub truncate(ByVal tableName As String)
	Call CurrentDb.execute("DELETE FROM " & tableName)
End Sub
</code>


====translateTableFields()====
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
<code vb 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
</code>


=====Rund um Formulare=====

====formIsLoaded()====
<code vb 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
</code>


====closeAllForms()====
<code vb 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
</code>


====cm2twips()====
<code vb 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
</code>


====twips2cm()====
<code vb 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
</code>



=====Rund um Access System=====
====changeProperty()====
<code vb 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
</code>


====objectExists()====
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.
<code vb 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
</code>

Und falls man zusätzlich auf die Existenz einer Funktion prüfen möchte, diesen Case noch hinzufügen
<code vb>
		' 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
		
</code>


{{tag>VBA MS_Access}}