All My DB Utilities (for DAO)

[cafeenman]

I love this file. I will marry this file if it will have me. I will be buried with this file. This file should have my babies.

DAO Utilities.zip


Edit: Of course you'll have to remove all the callstack and errorhandler stuff unless you have all that already set up and it's compatible which is about 100% not going to be.

Just get the meat of what you need out of it.

I posted some of the dependencies below.

[Eduardo-]

You will marry an empty file.

[cafeenman]

lolz! Let me try that again.

[cafeenman]

OK. Fixed. Thanks for pointing it out.

[rboeck]

Hi, i tried do use this file. I get many errors about unkown userdefinded type like SORT_DIRECTION etc.
I have already used microsoft dao 3.6, do you have a small running demo?

[cafeenman]

I'm sorry. There are a lot of dependencies in that file.


I'll go through the file and try to find all the dependencies.

CommonDialog is a Global Reference to a commondialog control on the MDI form.

Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpdirectory As String, ByVal nShowCmd As Long) As Long

Public Const ALL_FILES_FILTER As String = "All Files (*.*)|*.*|"

Public Const CHAR_COMMA As String = ","

Public Enum FILE_ACTION

  FILE_OPEN = 1
  FILE_SAVE = 2

End Enum

Public Enum SORT_DIRECTION

  idx_SortDirection_Unordered = 0
  idx_SortDirection_Ascending
  idx_SortDirection_Descending

End Enum

Public Const MIN_SORT_DIRECTION As Long = idx_SortDirection_Unordered
Public Const MAX_SORT_DIRECTION As Long = idx_SortDirection_Descending

Public Type OS_VERSION_INFOW

  dwOSVersionInfoSize As Long
  dwMajorVersion As Long
  dwMinorVersion As Long
  dwBuildNumber As Long
  dwPlatformId As Long
  szCSDVersion((128 * 2) - 1) As Byte

End Type


Public BlockedFieldOrTableName() As String

Public Function CreateBlockedWords() As Long

CallStack.Add NAME & ".CreateBlockedWords(Public Function)"

ReDim BlockedFieldOrTableName(4)

BlockedFieldOrTableName(0) = "accesslevelid"
BlockedFieldOrTableName(1) = "alter"
BlockedFieldOrTableName(2) = "create"
BlockedFieldOrTableName(3) = "drop"
BlockedFieldOrTableName(4) = "password"

CallStack.DeleteProcedureCall

End Function

Public Function MaxValue(ParamArray Values() As Variant) As Variant
Dim m_CallStacker As New cCallStacker
Dim n As Long
Dim nMax As Long

' Returns the Greatest Value.

m_CallStacker.Add NAME & ".MaxValue(Public Function)"

For n = LBound(Values) To UBound(Values)

  If Values(n) > nMax Then nMax = Values(n)

Next n

MaxValue = nMax

End Function

Function GetFileName(ByRef FileOpenOrSave As FILE_ACTION, InitialFilename As String, ByRef Flags As Long, ByRef Filters As String, ByRef FolderName As String, ByRef CurrentFilename As String, Optional ByRef Extension As String = vbNullString) As String
Dim nResult As Long
Dim FileSpec As String
Dim iExtensionLen As Integer

On Error GoTo errHandler

CallStack.Add NAME & ".GetFileName(Public Function)"

GetFileName = vbNullString

Top:

With CommonDialog

  .CancelError = True
  .Filename = InitialFilename
  .Flags = Flags Or cdlOFNHideReadOnly
  .Filter = Filters & ALL_FILES_FILTER
  .InitDir = FolderName

  Select Case FileOpenOrSave

    Case FILE_OPEN

      .Flags = .Flags Or cdlOFNFileMustExist

      If Not IsMissing(Extension) Then .DefaultExt = Extension

      .ShowOpen

      FileSpec = .Filename

      If Len(FileSpec) = 0 Then GoTo CleanUp

    Case FILE_SAVE

      .ShowSave

      FileSpec = Trim$(.Filename)

      If Len(FileSpec) = 0 Then GoTo CleanUp

      Extension = Replace(Extension, "*", vbNullString, 1, -1, vbTextCompare)

      iExtensionLen = Len(Extension)

      If Right$(FileSpec, iExtensionLen) <> Extension And Not InStr(1, FileSpec, CHAR_DOT, vbTextCompare) Then

        FileSpec = FileSpec & CHAR_DOT & Extension

      End If

      ' This case occurs only when a user tries to save the currently open file
      ' to itself using commands such as "save as" or "backup" etc.
      ' If the user selects "save" when the file already exists, the program
      ' flow should never enter this procedure.

      If FileExists(CurrentFilename) And (StrComp(CurrentFilename, FileSpec, vbTextCompare) = 0) Then

        MsgBoxA "Can't save file to itself.  Please choose a different file name to save as.", vbCritical, App.Title

        GoTo Top

      End If

      If FileExists(FileSpec) Then

        nResult = MsgBoxA("Overwrite existing " & FileSpec & "?", vbYesNoCancel + vbQuestion, App.Title)

        Select Case nResult

          Case vbYes

            ' Do nothing.

          Case vbNo

            GoTo Top ' Try again.

          Case vbCancel

            Err.Raise ERR_CANCELLED_BY_USER ' Return vbNullString.

        End Select

      End If

      nResult = CreateFolder(GetFolder(FileSpec), True)

      If nResult <> 0 Then Err.Raise nResult

    End Select

End With

GetFileName = FileSpec

CleanUp:

CallStack.DeleteProcedureCall

Exit Function

errHandler:
Dim nErrorHandlerResult As Long
Dim sError As String
Dim nErr As Long
Dim Parameters(10) As String

sError = Error
nErr = Err

If nErr = ERR_CANCELLED_BY_USER Or Err = 32755 Then Resume CleanUp

Parameters(0) = "FileOpenOrSave = " & CStr(FileOpenOrSave)
Parameters(1) = "InitialFilename = " & InitialFilename
Parameters(2) = "Flags = " & CStr(Flags)
Parameters(3) = "Filters = " & Filters
Parameters(4) = "FolderName = " & FolderName
Parameters(5) = "CurrentFilename = " & CurrentFilename
Parameters(6) = "Extension = " & Extension
Parameters(7) = "nResult = " & CStr(nResult)
Parameters(8) = "FileSpec = " & FileSpec
Parameters(9) = "iExtensionLen = " & CStr(iExtensionLen)
Parameters(10) = "CommonDialog.Filename = " & CommonDialog.Filename

nErrorHandlerResult = ErrorHandler(sError, nErr, ParameterString(Parameters), NAME & ".GetFileName(Public Function)")

If nErrorHandlerResult = vbRetry Then Resume Top

Resume CleanUp

End Function

Public Function ListIndexFromItemData(ByRef List As Control, ByVal Itemdata As Long, Optional ErrorValue As Long = 0) As Long
Dim nResult As Long
Dim n As Long
Dim Hourglass As New cHourglass

On Error GoTo errHandler

CallStack.Add NAME & ".ListIndexFromItemData(Public Function)"

nResult = -1

' Sets and returns the ListIndex of a List when given ItemData.

If Not IsList(List) Then GoTo CleanUp

Hourglass

With List

  For n = 0 To .ListCount - 1

    If Itemdata = .Itemdata(n) Then

      nResult = n

      Exit For

    End If

  Next n

End With

List.ListIndex = nResult

CleanUp:

ListIndexFromItemData = nResult

CallStack.DeleteProcedureCall

Exit Function

errHandler:
Dim nErrorHandlerResult As Long
Dim sError As String
Dim nErr As Long
Dim Parameters(2) As String

sError = Error
nErr = Err

ErrorValue = Err

Parameters(0) = "List.Name = " & List.NAME
Parameters(1) = "ItemData = " & CStr(Itemdata)
Parameters(2) = "n = " & CStr(n)

nErrorHandlerResult = ErrorHandler(sError, nErr, ParameterString(Parameters), NAME & ".ListIndexFromItemData (Public Function)")

Resume CleanUp

End Function

Public Function QueryReplaceFile(ByVal FileSpec As String) As VBA.VbMsgBoxResult
Dim nResult As Long

CallStack.Add NAME & ".QueryReplaceFile(Public Function)"

' Returns vbYes, vbNo, or vbCancel.
' Returns vbYes if File doesn't exist or if User chooses to overwrite file.

QueryReplaceFile = False

If Not FileExists(FileSpec) Then

  QueryReplaceFile = vbYes

  GoTo CleanUp

End If

nResult = MsgBoxA("Do you want to replace existing " & FileSpec & "?", vbYesNoCancel + vbQuestion, App.Title)
If nResult = vbYes Then DeleteFile FileSpec, RECYCLE_FILE, Date

QueryReplaceFile = nResult

CleanUp:

CallStack.DeleteProcedureCall

End Function

Public Function IsList(ByRef List As Control) As Boolean

' Determines if control is a List.

CallStack.Add NAME & ".IsList(Public Function)"

IsList = False

If List Is Nothing Then GoTo CleanUp

IsList = (TypeName(List) = "ListBox") Or (TypeName(List) = "ComboBox")

CleanUp:

CallStack.DeleteProcedureCall

End Function

Public Function InitListZer0(ByRef List As Control) As Long
Dim nErr As Long

' Returns Error Code.
On Error GoTo errHandler

CallStack.Add NAME & ".InitListZer0(Public Function)"

nErr = 0

' Selects first item in a ComboBox or ListBox.

If Not IsList(List) Then Err.Raise ERR_LIST_EXPECTED

With List

  If .ListCount > 0 Then .ListIndex = 0

End With

CleanUp:

InitListZer0 = nErr

CallStack.DeleteProcedureCall

Exit Function

errHandler:
Dim nErrorHandlerResult As Long

nErr = Err

nErrorHandlerResult = ErrorHandler(Error, nErr, vbNullString, NAME & ".InitListZer0(Public Function)")

Resume CleanUp

End Function

Public Function SelectDeselectAllInList(ByRef List As Control, ByRef SelectAll As Boolean) As Long
Dim nErr As Long
Dim n As Long

' Returns Error Code.
On Error GoTo errHandler

CallStack.Add NAME & ".SelectDeselectAllInList(Public Function)"

nErr = 0

If Not IsList(List) Then Err.Raise ERR_LIST_EXPECTED

With List

  If .ListCount = 0 Then GoTo CleanUp

  For n = .ListCount - 1 To 0 Step -1

    .Selected(n) = SelectAll

  Next n

End With

InitListZer0 List

CleanUp:

SelectDeselectAllInList = nErr

CallStack.DeleteProcedureCall

Exit Function

errHandler:
Dim nErrorHandlerResult As Long
Dim sError As String
Dim Parameters(2) As String

sError = Error
nErr = Err

Parameters(0) = "List.Name = " & List.NAME
Parameters(1) = "SelectAll = " & CStr(SelectAll)
Parameters(2) = "n = " & CStr(n)

nErrorHandlerResult = ErrorHandler(sError, nErr, ParameterString(Parameters), NAME & ".SelectDeselectAllInList(Public Function)")

Resume CleanUp

End Function

someone's msgbox code I nabbed off the internet. I like it a lot.

Option Explicit


' // Constants, Types and Enums.

Public Const NumBits As Byte = 64
Public Const vbTimedOut As Long = 32000 ' return if MsgBoxW times out

' // Constants, Types and Enums.


' // Properties.

Private nOSBits As Long
Private nOSBuild As Long
Private nOSVersion As Long

' // Properties


Private Function Init() As Long
Dim nErr As Long
Dim version_info As OS_VERSION_INFOW

' Returns Error Code.
On Error GoTo errHandler

CallStack.Add NAME & ".Init(Private Function)"

nErr = 0

OSBuild = 0

version_info.dwOSVersionInfoSize = Len(version_info)  '276

If GetVersionExW(version_info) = 0 Then

  OSVersion = -1 ' error of some sort. Shouldn't happen.

Else

  OSVersion = (version_info.dwMajorVersion * 100) + version_info.dwMinorVersion

  If version_info.dwPlatformId = 0 Then

    OSVersion = 301 ' Win 3.1

  Else

    OSBuild = version_info.dwBuildNumber

  End If

End If

If Len(Environ$("PROGRAMFILES(X86)")) > 0 Then OSBits = 64 Else OSBits = 32

CleanUp:

Init = nErr

CallStack.DeleteProcedureCall

Exit Function

errHandler:
Dim nErrorHandlerResult As Long

nErr = Err

nErrorHandlerResult = ErrorHandler(Error, nErr, vbNullString, NAME & ".Init(Private Function)")

Resume CleanUp

End Function
Public Function MsgBoxA(Optional Prompt As String = vbNullString, Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, Optional Title As String = vbNullString, Optional ByVal TimeOutMSec As Long = 30000, Optional Flags As Long = 0, Optional ByVal hWnd As Long = 0) As VbMsgBoxResult
Dim nResult As Long

On Error GoTo errHandler

CallStack.Add NAME & ".MsgBoxW(Public Function)"

sndPlaySound Ding(0), 1

If OSVersion < 600 Then ' WindowsVersion less then Vista

  Init

  If OSVersion < 600 Then ' earlier than Vista

    If (Buttons And 15) = vbAbortRetryIgnore Then

      Buttons = (Buttons And 2147483632) Or 6 ' (7FFFFFFF xor 15) or 6

    End If

  End If

End If

nResult = MessageBoxTimeoutW(hWnd, StrPtr(Prompt), StrPtr(Title), Buttons Or Flags, 0, TimeOutMSec)

If nResult > vbNo Then nResult = vbCancel

MsgBoxA = nResult

CleanUp:

CallStack.DeleteProcedureCall

Exit Function

errHandler:
Dim nErrorHandlerResult As Long

nErrorHandlerResult = ErrorHandler(Error, Err, vbNullString, NAME & ".MsgBoxW(Public Function)")

Resume CleanUp

End Function
Public Property Get NAME() As String

CallStack.Add NAME & "bMsgBox_Name(Public Property Get)"

NAME = "bMsgBox"

CallStack.DeleteProcedureCall

End Property
Private Property Get OSBits() As Long

CallStack.Add NAME & ".OSBits(Private Property Get)"

OSBits = nOSBits

CallStack.DeleteProcedureCall

End Property
Private Property Let OSBits(ByVal BitsNumber As Long)

CallStack.Add NAME & ".OSBits(Private Property Let)"

nOSBits = BitsNumber

CallStack.DeleteProcedureCall

End Property
Private Property Get OSBuild() As Long

CallStack.Add NAME & ".OSBuild(Private Property Get)"

OSBuild = nOSBuild

CallStack.DeleteProcedureCall

End Property
Private Property Let OSBuild(ByVal BuildNumber As Long)

CallStack.Add NAME & ".OSBuild(Private Property Let)"

nOSBuild = BuildNumber

CallStack.DeleteProcedureCall

End Property
Private Property Get OSVersion() As Long

CallStack.Add NAME & ".OSVersion(Private Property Get)"

OSVersion = nOSVersion

CallStack.DeleteProcedureCall

End Property
Private Property Let OSVersion(ByVal VersionNumber As Long)

CallStack.Add NAME & ".OSVersion(Private Property Let)"

nOSVersion = VersionNumber

CallStack.DeleteProcedureCall

End Property

Option Explicit


Public Sub Hourglass(Optional ByVal SetHourglass As Boolean = True)

CallStack.Add Me.NAME & ".Hourglass(Public Sub)"

If SetHourglass = False Then

  Screen.MousePointer = vbNormal

Else

  Screen.MousePointer = vbHourglass

End If

DoEvents

CallStack.DeleteProcedureCall

End Sub
Public Property Get NAME() As String

CallStack.Add "cHourglass_Name(Public Property Get)"

NAME = "cHourglass"

CallStack.DeleteProcedureCall

End Property
Private Sub Class_Initialize()

CallStack.Add Me.NAME & ".Class_Initialize(Private Sub)"

Hourglass True

CallStack.DeleteProcedureCall

End Sub
Private Sub Class_Terminate()

CallStack.Add Me.NAME & ".Class_Terminate(Private Sub)"

Hourglass False

CallStack.DeleteProcedureCall

End Sub

[cafeenman]

This is quite the rabbit-hole. More dependencies:

Public Const  ERR_CANCELLED_BY_USER As Long = 747  ' Error returned when user selects cancel in a common dialog.

Public Function GetFolder(ByRef FileSpec As String) As String
Dim FSO As New FileSystemObject

On Error GoTo errHandler

CallStack.Add NAME & ".GetFolder(Public Function)"

GetFolder = vbNullString

' Returns the path without the FileSpec.
GetFolder = NormalizePath(FSO.GetParentFolderName(FileSpec))

CleanUp:

Set FSO = Nothing

CallStack.DeleteProcedureCall

Exit Function

errHandler:
Dim nErrorHandlerResult As Long
Dim sError As String
Dim nErr As Long
Dim Parameters(0) As String

sError = Error
nErr = Err

Parameters(0) = "FileSpec = " & FileSpec

nErrorHandlerResult = ErrorHandler(sError, nErr, ParameterString(Parameters), NAME & ".GetFolder(Public Function)")

Resume CleanUp

End Function

Public Function CreateFolder(ByVal FolderName As String, PromptForFolderCreation As Boolean) As Long
Dim nResult As Long
Dim nErr As Long
Dim FSO As New FileSystemObject

' Returns Error Code.
On Error GoTo errHandler

CallStack.Add NAME & ".CreateFolder(Public Function)"

nErr = 0

' Function should be called any time a user is prompted for a filename to save to.
' If the folder exists, the functions does nothing and exits.

If FSO.FolderExists(FolderName) Then GoTo CleanUp

If Not PromptForFolderCreation Then

  nResult = CreatePath(FolderName)

  If nResult <> 0 Then Err.Raise nResult

Else

  nResult = MsgBoxA("The folder " & FolderName & " does not exist.  Do you want to create it?", vbYesNo + vbQuestion, App.Title)

  Select Case nResult

    Case vbYes

      nResult = CreatePath(FolderName)

      If nResult <> 0 Then Err.Raise nResult

    Case vbNo

      nErr = ERR_CANCELLED_BY_USER

      GoTo CleanUp

  End Select

End If

CleanUp:

CreateFolder = nErr

Set FSO = Nothing

CallStack.DeleteProcedureCall

Exit Function

errHandler:
Dim nErrorHandlerResult As Long
Dim sError As String
Dim Parameters(2) As String

sError = Error
nErr = Err

Parameters(0) = "FolderName = " & FolderName
Parameters(1) = "PromptForFolderCreation = " & CStr(PromptForFolderCreation)
Parameters(2) = "nResult = " & CStr(nResult)

If nResult = 0 Then

  nErrorHandlerResult = ErrorHandler(sError, nErr, ParameterString(Parameters), NAME & ".CreateFolder(Public Function)")

End If

Resume CleanUp

End Function

Public Function NormalizePath(ByVal FolderName As String)
Dim s As String

CallStack.Add NAME & ".NormalizePath(Public Function)"

s = TrimNull(Trim$(FolderName))

If Len(s) = 0 Then GoTo CleanUp

If Right$(s, 1) <> BACK_SLASH Then s = s & BACK_SLASH

NormalizePath = s

CleanUp:

CallStack.DeleteProcedureCall

End Function

[rboeck]

Thanks a lot! The used callstack technologie is a creation of you or is it part of an commercial error handler?

[cafeenman]

I made it up not having a clue how it should be properly done.