Results 1 to 9 of 9

Thread: All My DB Utilities (for DAO)

  1. #1

    Thread Starter
    PowerPoster cafeenman's Avatar
    Join Date
    Mar 2002
    Location
    Florida
    Posts
    2,636

    All My DB Utilities (for DAO)

    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.
    Last edited by cafeenman; Apr 4th, 2024 at 02:00 AM.

  2. #2
    PowerPoster
    Join Date
    Feb 2017
    Posts
    5,118

    Re: All My DB Utilities (for DAO)

    You will marry an empty file.

  3. #3

    Thread Starter
    PowerPoster cafeenman's Avatar
    Join Date
    Mar 2002
    Location
    Florida
    Posts
    2,636

    Re: All My DB Utilities (for DAO)

    lolz! Let me try that again.

  4. #4

    Thread Starter
    PowerPoster cafeenman's Avatar
    Join Date
    Mar 2002
    Location
    Florida
    Posts
    2,636

    Re: All My DB Utilities (for DAO)

    OK. Fixed. Thanks for pointing it out.

  5. #5
    Junior Member
    Join Date
    Nov 2016
    Posts
    20

    Re: All My DB Utilities (for DAO)

    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?

  6. #6

    Thread Starter
    PowerPoster cafeenman's Avatar
    Join Date
    Mar 2002
    Location
    Florida
    Posts
    2,636

    Re: All My DB Utilities (for DAO)

    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.


    Code:
    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.

    Code:
    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
    Code:
    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
    Last edited by cafeenman; Apr 4th, 2024 at 02:06 AM.

  7. #7

    Thread Starter
    PowerPoster cafeenman's Avatar
    Join Date
    Mar 2002
    Location
    Florida
    Posts
    2,636

    Re: All My DB Utilities (for DAO)

    This is quite the rabbit-hole. More dependencies:

    Code:
    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

  8. #8
    Junior Member
    Join Date
    Nov 2016
    Posts
    20

    Re: All My DB Utilities (for DAO)

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

  9. #9

    Thread Starter
    PowerPoster cafeenman's Avatar
    Join Date
    Mar 2002
    Location
    Florida
    Posts
    2,636

    Re: All My DB Utilities (for DAO)

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

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width