For the life of me I can't find out the reason why code stopped compiling, it has a runtime error 28 - Out of Stack Space
It used to compile fine and it stopped with new update to Windows 10. Not even sure if that is related. Could it be just too many utilities in one module?
It is mostly just supposed to have all the message boxes, set the date to a fiscal year format and export the tables to a backup excel spreadsheet.
Any ideas greatly appreciated!
Option Compare Database
Option Explicit
Global CurrentUserID As Long
Global CurrentUsername As String
Global CurrentUserPrivileges As UserPrivilegesEnum
Const FMonthStart = 10
Const FDayStart = 1
Const FYearOffset = -1
Public cmd As New Commands
Global lHeader As Long
Global lHeaderText As Long
Global lBodyText As Long
Global lDetail As Long
Public Enum StringIDEnum
AppTitle = 1
DebuggingMessage = 2
ErrorHasOccured = 3
ELookupError = 4
SaveChangesPrompt = 5
ConfirmParaLNDeletion = 6
NoRecordsChanged = 7
CannotDeleteAssignedParaln = 8
End Enum
Public Enum UserPrivilegesEnum
ADMIN = 1
User = 2
Inactivated = 3
End Enum
Function MsgBoxYesNo(StringID As StringIDEnum, Optional ByVal strInsert As String) As Boolean
MsgBoxYesNo = vbYes = MsgBoxID(StringID, vbYesNo, strInsert)
End Function
Sub MsgBoxOKOnly(StringID As StringIDEnum, Optional ByVal strInsert As String)
MsgBoxID StringID, vbOKOnly, strInsert
End Sub
Function MsgBoxYesNoCancel(StringID As StringIDEnum, Optional ByVal strInsert As String)
MsgBoxYesNoCancel = MsgBoxID(StringID, vbYesNoCancel, strInsert)
End Function
Function MsgBoxOKCancel(StringID As StringIDEnum, Optional ByVal strInsert As String)
MsgBoxOKCancel = MsgBoxID(StringID, vbOKCancel, strInsert)
End Function
Function MsgBoxID(StringID As StringIDEnum, Buttons As VbMsgBoxStyle, Optional ByVal strInsert As String) As VbMsgBoxResult
MsgBoxID = MsgBox(InsertString(StringID, strInsert), Buttons, LoadString(AppTitle))
End Function
Function LoadString(StringID As StringIDEnum) As String
LoadString = ELookup("[StringData]", "tblStrings", "[StringID]=" & StringID)
' Verify that the specified string was found using DLookupStringWrapper.
' If you hit this breakpoint, verify that the StringID exists in the Strings table.
Debug.Assert LoadString <> ""
End Function
Function InsertString(StringID As StringIDEnum, strInsert As String) As String
InsertString = Replace(LoadString(StringID), "|", strInsert)
End Function
Function GetFiscalYear(ByVal X As Variant)
On Error GoTo ErrorHandler
If X < DateSerial(Year(X), FMonthStart, FDayStart) Then
GetFiscalYear = Year(X) - FYearOffset - 1
Else
GetFiscalYear = Year(X) - FYearOffset
End If
Done:
Exit Function
ErrorHandler:
Call LogError(Err.Number, Err.Description, "GetFisalYear() -- GetFiscalYear")
Resume Done
End Function
Function GetMonthEnd(ByVal X As Variant)
On Error GoTo ErrorHandler
Dim M As Variant
M = DateSerial(Year(X), Month(X) + 1, 0)
GetMonthEnd = M
Done:
Exit Function
ErrorHandler:
Call LogError(Err.Number, Err.Description, "GetFisalYear() -- GetMonthEnd")
Resume Done
End Function
Public Function Proper(X)
'Capitalize first letter of every word in a field.
Dim Temp$, C$, OldC$, i As Integer
If IsNull(X) Then
Exit Function
Else
Temp$ = CStr(LCase(X))
' Initialize OldC$ to a single space because first
' letter must be capitalized but has no preceding letter.
OldC$ = " "
For i = 1 To Len(Temp$)
C$ = Mid$(Temp$, i, 1)
If C$ >= "a" And C$ <= "z" And (OldC$ < "a" Or OldC$ > "z") Then
Mid$(Temp$, i, 1) = UCase$(C$)
End If
OldC$ = C$
Next i
Proper = Temp$
End If
End Function
Public Sub OpenSpecificExcelFile(sFilePath)
On Error GoTo ErrorHandler
Dim oXL As Object
Dim oExcel As Object
Dim sFullPath As String
Dim sPath As String
Set oXL = CreateObject("Excel.Application")
' Only XL 97 supports UserControl Property
On Error Resume Next
oXL.UserControl = True
On Error GoTo 0
' Full path of excel file to open
On Error GoTo ErrorHandler
' Open it
With oXL
.Visible = True
.Workbooks.Open (sFilePath)
End With
Done:
Set oXL = Nothing
Exit Sub
ErrorHandler:
oXL.Visible = False
MsgBox Err.Description
GoTo Done
End Sub
Public Function QueryExists(QueryName As String) As Boolean
Dim Db As Database 'DAO Vars
Dim QDF As DAO.QueryDef
On Error GoTo NoQuery 'If there is no Query capture the error.
Set Db = CurrentDb()
'If Query is there return True
For Each QDF In Db.QueryDefs
If QDF.Name = QueryName Then
QueryExists = True
Db.Close
Set Db = Nothing
Exit For
End If
Next
Exit Function
NoQuery:
'If Query is not there close out and set function to false
Db.Close
Set Db = Nothing
QueryExists = False
Exit Function
End Function
Public Function CreateOrgCharts() As Boolean
On Error GoTo ErrorHandler
Dim strFilePath As String
Dim varDate As Variant
varDate = Format(Date, "yyyymmdd") & "_" & Replace(Replace(Replace(Format(Time, "Long Time"), ":", ""), " AM", "AM"), " PM", "PM")
strFilePath = "Org_Charts_" & varDate & ".xls"
DoCmd.TransferSpreadsheet acExport, _
acSpreadsheetTypeExcel8, "qryOrgCharts", _
strFilePath, , "Org Charts"
CreateOrgCharts = True
Done:
Exit Function
ErrorHandler:
Call LogError(Err.Number, Err.Description, "CreateOrgCharts() -- mdlUtilies")
Resume Done
End Function
Public Function Backup() As Boolean
On Error GoTo ErrorHandler
Dim strFilePath As String
Dim varDate As Variant
varDate = Format(Date, "yyyymmdd") & "_" & Replace(Replace(Replace(Format(Time, "Long Time"), ":", ""), " AM", "AM"), " PM", "PM")
strFilePath = "Toolkit_backup_files_" & varDate & ".xls"
DoCmd.TransferSpreadsheet acExport, _
acSpreadsheetTypeExcel8, "tblEmerContact", _
strFilePath, , "Emer Contact Info"
DoCmd.TransferSpreadsheet acExport, _
acSpreadsheetTypeExcel8, "tblMovements", _
strFilePath, , "Movements"
DoCmd.TransferSpreadsheet acExport, _
acSpreadsheetTypeExcel8, "tblUsers", _
strFilePath, , "User Info"
Backup = True
Done:
Exit Function
ErrorHandler:
Call LogError(Err.Number, Err.Description, "Backup() -- mdlUtilies")
Resume Done
End Function
Public Function BackupReferenceTables() As Boolean
On Error GoTo ErrorHandler
Dim strFilePath As String
Dim varDate As Variant
varDate = Format(Date, "yyyymmdd") & "_" & Replace(Replace(Replace(Format(Time, "Long Time"), ":", ""), " AM", "AM"), " PM", "PM")
strFilePath = "Toolkit_ReferenceTables_backup_files_" & varDate & ".xls"
DoCmd.TransferSpreadsheet acExport, _
acSpreadsheetTypeExcel8, "tblPositions", _
strFilePath, , "Positions"
DoCmd.TransferSpreadsheet acExport, _
acSpreadsheetTypeExcel8, "tblSection", _
strFilePath, , "Sections"
BackupReferenceTables = True
Done:
Exit Function
ErrorHandler:
Call LogError(Err.Number, Err.Description, "Backup_reference_tables() -- mdlUtilies")
Resume Done
End Function
Function IsSelectedVar( _
strFormName As String, _
strListBoxName As String, _
varValue As Variant) _
As Boolean
'strFormName is the name of the form
'strListBoxName is the name of the listbox
'varValue is the field to check against the listbox
Dim lbo As ListBox
Dim item As Variant
If IsNumeric(varValue) Then
varValue = Trim(str(varValue))
End If
Set lbo = Forms(strFormName)(strListBoxName)
For Each item In lbo.ItemsSelected
If lbo.ItemData(item) = varValue Then
IsSelectedVar = True
Exit Function
End If
Next
End Function
