Option Explicit
#Const DEBUG_MODE = 1
#Const PROD_MODE = 0
#Const APP_MODE = DEBUG_MODE
Public Const msMODULE As String = "modGeneral"
Public Enum OfficeProduct
Access2007Only = 1
[MSAccess95-2003]
Excel2007Only
[MSExcel95-2003]
[XML]
End Enum
Public Function FixSingleQuotes(varValue As Variant) As String
Const SINGLEQUOTE = "'"
FixSingleQuotes = SINGLEQUOTE & _
Replace(varValue, SINGLEQUOTE, SINGLEQUOTE & SINGLEQUOTE) & _
SINGLEQUOTE
End Function
Public Function FixSQLforRecordset(varValue As Variant) As Variant
Const SINGLEQUOTE = "'"
If IsNull(varValue) Then Exit Function
FixSQLforRecordset = Replace(varValue, SINGLEQUOTE, SINGLEQUOTE & SINGLEQUOTE)
End Function
Function getSaveAs2(iOfficeVersion As OfficeProduct, _
Optional bAllowMultiSelect As Boolean = False, _
Optional strInitialFileName As String) As String
Const ssource As String = "getSaveAs2"
Dim fDialog As Office.FileDialog
On Error GoTo ErrorHandler
' Requires reference to Microsoft Office 11.0 Object Library.
' Set up the File Dialog.
'Set fDialog = Application.FileDialog(
Set fDialog = Application.FileDialog(
With fDialog
'.AllowMultiSelect = bAllowMultiSelect
'If Len(strInitialFileName) Then
' .InitialFileName = strInitialFileName
'End If
' Set the title of the dialog box.
.Title = "Please select one or more files"
' Clear out the current filters, and add our own.
If .Filters.Count > 0 Then
'.Filters.Clear
End If
'Select Case iOfficeVersion
' Case OfficeProduct.Excel2007Only
' .Filters.Add "Excel 2007 Workbooks", "*.XLSX"
' .Filters.Add "All Files", "*.*"
' Case OfficeProduct.Access2007Only
' .Filters.Add "Access Databases", "*.MDB"
' .Filters.Add "Access Projects", "*.ADP"
' .Filters.Add "All Files", "*.*"
' Case Else
' .Filters.Add "All Files", "*.*"
'End Select
' Show the dialog box. If the .Show method returns True, the
' user picked at least one file. If the .Show method returns
' False, the user clicked Cancel.
If .Show Then
getSaveAs2 = .SelectedItems(1)
End If
End With
ExitProc:
On Error Resume Next
Set fDialog = Nothing
Exit Function
ErrorHandler:
If bCentralErrorHandler(msMODULE, "getSaveAs2") Then
Stop
Resume
Else
Resume ExitProc
End If
End Function
Function getFolderDestination(Optional strInitialFileName As String) As String
Const ssource As String = "getSaveAs2"
Dim fDialog As Office.FileDialog
On Error GoTo ErrorHandler
' Requires reference to Microsoft Office 11.0 Object Library.
' Set up the File Dialog.
'Set fDialog = Application.FileDialog(
Set fDialog = Application.FileDialog(
With fDialog
If Len(strInitialFileName) Then
.InitialFileName = strInitialFileName
End If
' Set the title of the dialog box.
'.Title = "Please select one or more files"
' Show the dialog box. If the .Show method returns True, the
' user picked at least one file. If the .Show method returns
' False, the user clicked Cancel.
If .Show Then
getFolderDestination = .SelectedItems(1)
End If
End With
ExitProc:
On Error Resume Next
Set fDialog = Nothing
Exit Function
ErrorHandler:
If bCentralErrorHandler(msMODULE, "getSaveAs2") Then
Stop
Resume
Else
Resume ExitProc
End If
End Function
Function getFileOpen2(iOfficeVersion As OfficeProduct, _
Optional bAllowMultiSelect As Boolean = False, _
Optional strInitialFileName As String, _
Optional ByVal strTitle As String) As String
Const ssource As String = "getFileOpen2"
Dim fDialog As Office.FileDialog
On Error GoTo ErrorHandler
' Requires reference to Microsoft Office 11.0 Object Library.
' Set up the File Dialog.
Set fDialog = Application.FileDialog(
'Set fDialog = Application.FileDialog(
With fDialog
.AllowMultiSelect = bAllowMultiSelect
'If Len(strInitialFileName) Then
' .InitialFileName = strInitialFileName
'End If
' Set the title of the dialog box.
If Len(strTitle) > 0 Then
.Title = strTitle
Else
.Title = "Please select one or more files"
End If
' Clear out the current filters, and add our own.
.Filters.Clear
Select Case iOfficeVersion
Case OfficeProduct.Excel2007Only
.Filters.Add "Excel 2007 Workbooks", "*.XLSX"
.Filters.Add "All Files", "*.*"
Case OfficeProduct.Access2007Only
.Filters.Add "Access Databases", "*.MDB"
.Filters.Add "Access Projects", "*.ADP"
.Filters.Add "All Files", "*.*"
Case OfficeProduct.XML
' .Filters.Add "All Files", "*.*"
.Filters.Add "XML Files", "*.XML"
Case Else
.Filters.Add "All Files", "*.*"
End Select
' Show the dialog box. If the .Show method returns True, the
' user picked at least one file. If the .Show method returns
' False, the user clicked Cancel.
If .Show Then
getFileOpen2 = .SelectedItems(1)
End If
End With
ExitProc:
On Error Resume Next
Set fDialog = Nothing
Exit Function
ErrorHandler:
If bCentralErrorHandler(msMODULE, "getSaveAs2") Then
Stop
Resume
Else
Resume ExitProc
End If
End Function
Public Function FeatureNotAvailibleYet() As Boolean
MsgBox "In development but feature is not availible yet ", vbInformation
End Function
Public Function isLoaded(strFormName As String) As Boolean
Const FORMOPEN = -1
Const FORMCLOSED = 0
If SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> FORMCLOSED Then
isLoaded = True
Else
isLoaded = False
End If
End Function
Function CheckFieldSize2(ctrl As Control, strFieldName As String, intMaxSize As Integer) As Boolean
Dim strValue As String
Dim strMsg As String
strValue = Nz(ctrl.Value, "")
If Len(strValue) > intMaxSize Then
'warn the user
strMsg = "The " & strFieldName & " field can only accept a maximum of " & _
intMaxSize & " characters " & "The field has been truncated to the maximum size"
MsgBox strMsg, vbCritical, "Validate Control"
End If
End Function
Public Function CanNavigateInForm(iMode As ACTION_MODE) As Boolean
'checks to see if the user is currently updating/adding a record before navigating
'to another record
Dim strErrorMsg As String
strErrorMsg = "You can't select another record while updating the existing record. Either continue " & _
"your actions or hit cancel to move off the current record."
If iMode <> ACTION_MODE.navigate Then
MsgBox strErrorMsg, vbInformation, "Invalid record movement"
CanNavigateInForm = False
Else
CanNavigateInForm = True
End If
End Function
Function CanCloseWindow(iMode As ACTION_MODE) As Boolean
If iMode <> navigate Then
MsgBox "Can't close while updating or adding the record." & vbCrLf & _
"Please first complete action or cancel updating/editing", vbInformation, "Confirm action"
CanCloseWindow = False
Else
CanCloseWindow = True
End If
End Function
Function setOrderBy(f As SubForm, PrimarySort As String, Optional SecondarySort, _
Optional TertiarySort) As Boolean
Const ssource As String = "setOrderBy"
Dim strOrderByClause As String
On Error GoTo ErrorHandler
strOrderByClause = PrimarySort
If Len(SecondarySort) Then
strOrderByClause = strOrderByClause & "," & SecondarySort
End If
If Len(TertiarySort) Then
strOrderByClause = strOrderByClause & "," & TertiarySort
End If
With f.Form
.OrderBy = strOrderByClause
.OrderByOn = True
End With
ExitProc:
On Error Resume Next
Exit Function
ErrorHandler:
If bCentralErrorHandler(msMODULE, ssource) Then
Stop
Resume
Else
Resume ExitProc
End If
End Function
Public Sub ReLogin()
On Error Resume Next
If CurrentProject.AllForms("
Forms!frmLogon.Visible = True
Else
MsgBox "frmlogon has been inadvertly closed"
End If
End Sub
Public Sub ChangePreferences()
On Error Resume Next
If CurrentProject.AllForms("
Forms!Preferences.Visible = True
Else
'MsgBox "Preferences has been inadvertly closed"
DoCmd.OpenForm "Preferences", , , , , acHidden
End If
End Sub
Function CheckFieldSize(ctrl As Control, strFieldName As String, intMaxSize As Integer) As Boolean
Const ssource As String = "CheckFieldSize"
Dim strValue As String
Dim strMsg As String
On Error GoTo ErrorHandler
strValue = Nz(ctrl.Value, "")
If Len(strValue) > intMaxSize Then
On Error GoTo 0
Err.Raise vbObjectError + 1, "The " & strFieldName & _
" can only accept a maximum of " & intMaxSize & " characters." & _
"The field has been truncated to the maximum size", ssource
CheckFieldSize = False
Else
CheckFieldSize = True
End If
ExitProc:
On Error Resume Next
Exit Function
ErrorHandler:
If bCentralErrorHandler(msMODULE, ssource) Then
Stop
Resume
Else
Resume ExitProc
End If
End Function
Public Function bOkToOverWrite(sFullName As String) As Boolean
Dim sMsg As String
Dim nButtons As Long
Dim nResponse As Long
Dim bOverwrite As Boolean
bOverwrite = False
sMsg = sFullName & " already exists. Do you want to overwrite it?"
nButtons = vbYesNoCancel + vbExclamation + vbDefaultButton2
nResponse = MsgBox(sMsg, nButtons, "Overwrite File?")
If nResponse = vbYes Then
bOverwrite = True
End If
bOkToOverWrite = bOverwrite
End Function
Public Function FileExists(sFullName As String) As Boolean
Dim bExists As Boolean
Dim nLength As Integer
nLength = Len(Dir(sFullName))
If nLength > 0 Then
bExists = True
Else
bExists = False
End If
FileExists = bExists
End Function
Public Function GetShortName(sLongName As String) As String
Dim sPath As String
Dim sShortName As String
BreakdownName sLongName, sShortName, sPath
GetShortName = sShortName
End Function
Public Function JustPathfromFileName(sLongName As String) As String
Dim sPath As String
Dim sShortName As String
BreakdownName sLongName, sShortName, sPath
JustPathfromFileName = sPath
End Function
Sub BreakdownName(sFullName As String, _
ByRef sname As String, _
ByRef sPath As String)
Dim nPos As Integer
' Find out where the file name begins
nPos = FileNamePosition(sFullName)
If nPos > 0 Then
sname = Right(sFullName, Len(sFullName) - nPos)
sPath = Left(sFullName, nPos - 1)
Else
'Invalid sFullName - don't change anything
End If
End Sub
' Returns the position or index of the first
' character of the file name given a full name
' A full name consists of a path and a filename
' Ex. FileNamePosition("C:\Testing\
Public Function FileNamePosition(sFullName As String) As Integer
Dim bFound As Boolean
Dim nPosition As Integer
bFound = False
nPosition = Len(sFullName)
Do While bFound = False
' Make sure we were not dealt a
' zero-length string
If nPosition = 0 Then Exit Do
' We are looking for the first "\"
' from the right.
If Mid(sFullName, nPosition, 1) = "\" Then
bFound = True
Else
' Working right to left
nPosition = nPosition - 1
End If
Loop
If bFound = False Then
FileNamePosition = 0
Else
FileNamePosition = nPosition
End If
End Function
Function SendEmailviaOutLook(strTo As String, strSubject As String, _
strBody As String, aAttachments As Variant)
Const ssource As String = "SendEmailviaOutLook"
Dim objOutlook As Object 'Outlook.Application
Dim objMail As Object 'Outlook.MailItem
Dim i As Integer
Dim bSendOut As Boolean
On Error GoTo ErrorHandler
DoCmd.Hourglass True
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
bSendOut = Not (objOutlook Is Nothing)
On Error GoTo ErrorHandler
If bSendOut Then
With objOutlook
'Set objMail = objOutlook.CreateItem(
Set objMail = objOutlook.CreateItem(0)
With objMail
'
.To = strTo
'.BodyFormat = olFormatHTML
'.HTMLBody = strBody
.Body = strBody
.Subject = strSubject
For i = LBound(aAttachments) To UBound(aAttachments)
.Attachments.Add aAttachments(i)
Next
'.Display
.Send
End With
End With
Set objMail = Nothing
'--------- part C ----------
'send the email out to the client
SendEmailviaOutLook = True
End If
ExitProc:
On Error Resume Next
Set objOutlook = Nothing
Set objMail = Nothing
DoCmd.Hourglass False
Exit Function
ErrorHandler:
If Err.Number = 429 Then
'Outlook is not running so try again with CreateObject
Set objOutlook = CreateObject("Outlook.
Resume Next
ElseIf bCentralErrorHandler(msMODULE, ssource) Then
Stop
Resume
Else
Resume ExitProc
End If
End Function
No comments:
Post a Comment