Printable View
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.
Attachment 191034
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.
You will marry an empty file.
lolz! Let me try that again. :)
OK. Fixed. Thanks for pointing it out.
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?
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.
someone's msgbox code I nabbed off the internet. I like it a lot.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
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
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
Thanks a lot! The used callstack technologie is a creation of you or is it part of an commercial error handler?
I made it up not having a clue how it should be properly done.