Einfache Lösungen für MS Access

Die folgenden Funktionen habe ich sorgfältig geprüft und in eigenen Projekten genutzt. Trotzdem kann ich keine Haftung übernehmen. Die Verwendung ist auf eigenen Gefahr.

DScores
Diese Funktion liefert die Anzahl der Datensätze einer Tabelle gfls. mit Filterbedingung.
CountFiles
Diese Funktion gibt die Anzahl der Dateien in einem bestimmten Verzeichnis und gfls. den darunter liegenden Verzeichnissen aus.
IsOpen
Diese Funktion ermittelt, ob eine Datei bereits geöffnet ist - Idee von mvps.org/access, Erweiterung (err.number) Thomas Eicker
DBSize
Die Funktion liefert die Dateigröße der aktuellen Datenbank, gfls. mit formatierter Ausgabe
GetAccVersAndSP
Diese Funktion liefert Version und Servicepack von Access

DScores 

Public Function DScores(Domain As String, Optional SQLWhereClaus As String) As Long
On Error GoTo er_DScores
Dim cnx As ADODB.Connection, rst As ADODB.Recordset
If Left(Domain, 6) <> "SELECT" Then
   If Left(Domain, 1) <> "[" Then Domain = "[" & Domain
   If Right(Domain, 1) <> "]" Then Domain = Domain & "]"
   If SQLWhereClaus <> "" Then _
      Domain = "SELECT * FROM " & Domain & " WHERE (" & SQLWhereClaus & ");"
End If
Set cnx = CurrentProject.Connection
Set rst = New ADODB.Recordset
rst.Open Domain, cnx, adOpenStatic, adLockReadOnly
DScores = rst.RecordCount
ex_DScores:
   On Error Resume Next
   rst.Close
   Set rst = Nothing
   cnx.Close
   Set cnx = Nothing
   Exit Function
er_DScores:
   DScores = 0
   Resume ex_DScores
End Function

nach oben

CountFiles 

Public Function CountFiles(Directory As String, _
      Optional Filetype As String, _
      Optional InclSubFolders As Boolean) As Long
Dim lngFT As Long
If Directory = "" Then GoTo WithoutFiles
Select Case Filetype
Case "xls", "xlsx": lngFT = msoFileTypeExcelWorkbooks
Case "doc", "docx": lngFT = msoFileTypeWordDocuments
Case Else: lngFT = msoFileTypeAllFiles
End Select
With Application.FileSearch
   .LookIn = Directory
   .SearchSubFolders = InclSubFolders
   .Filetype = lngFT
   If .Execute() > 0 Then
     CountFiles = .FoundFiles.count
     Exit Function
   End If
End With
WithoutFiles:
   CountFiles = 0
End Function

nach oben

IsOpen 

Public Function IsOpen(sDateiname) As Boolean
On Error GoTo er_IsOpen
Dim intFree As Integer
intFree = FreeFile()
Open sDateiname For Input Lock Read As intFree
IsOpen = False
ex_IsOpen:
   On Error Resume Next
   Close #intFree
   Exit Function
er_IsOpen:
   Select Case Err.Number
   Case 70 ' Zugrif verweigert
     IsOpen = True
   Case Else
     IsOpen = False
   End Select
   Resume ex_IsOpen
End Function

nach oben

DBSize 

Function DBSize(Optional sDatabase As String, Optional fFormated As Boolean) As Variant
If Len(sDatabase) = 0 Then sDatabase = CurrentDb.Name
DBSize = FileLen(sDatabase)
If fFormated Then
   Select Case DBSize
   Case Is < 10240
   Case Is < 1048576
     DBSize = Round(DBSize / 1024, 0) & " KB"
   Case Is < 1073741824
     DBSize = Round(DBSize / 1048576, 1) & " MB"
   Case Else
     DBSize = Round(DBSize / 1073741824, 2) & " GB"
   End Select
End If
End Function

nach oben

GetAccVersAndSP 

Function GetAccVersAndSP(Optional ShowServicePack As Boolean = True) As String
Dim strVers As String, strSP As String
   Select Case Val(SysCmd(acSysCmdAccessVer))
    Case 9 'Access 2000
      strVers = "Access 2000"
      Select Case SysCmd(715)
       Case 2719: strSP = "Kein SP!"
       Case Is >= 6620: strSP = "SP-3"
       Case Is >= 4506: strSP = "SP-2"
       Case Is >= 3822: strSP = "SP-1"
       Case Else: strSP = "Unbekanntes SP!"
      End Select
    Case 10 'Access 2002/XP
      strVers = "Access 2002/XP"
      Select Case SysCmd(715)
       Case 2627: strSP = "Kein SP!"
       Case Is >= 6501: strSP = "SP-3"
       Case Is >= 4302: strSP = "SP-2"
       Case Is >= 3409: strSP = "SP-1"
       Case Else: strSP = "Unbekanntes SP (" & SysCmd(715) & ")"
      End Select
    Case 11 'Access 2003
      strVers = "Access 2003"
      Select Case SysCmd(715)
       Case 5614: strSP = "Kein SP!"
       Case Is >= 8166: strSP = "SP-3"
       Case Is >= 6566: strSP = "SP-2"
       Case Is >= 6355: strSP = "SP-1"
       Case Else: strSP = "Unbekanntes SP (" & SysCmd(715) & ")"
      End Select
   Case 12 'Access 2007
      strVers = "Access 2007"
      Select Case SysCmd(715)
      Case Is >= 6423: strSP = "SP-1"
      Case Else: strSP = "Unbekanntes SP (" & SysCmd(715) & ")"
      End Select
   Case 14 'Access 2010
      strVers = "Access 2010"
      Select Case SysCmd(715)
      Case Is >= 7104: strSP = "SP-1"
      Case Else: strSP = "Unbekanntes SP (" & SysCmd(715) & ")"
      End Select
   Else
      strVers = "unbekannte Version"
      ShowServicePack = False
   End Select
   If ShowServicePack Then
     GetAccVersAndSP = strVers & ", " & strSP
   Else
     GetAccVersAndSP = strVers
   End If
End Function

nach oben