Visual Basic For Applications (VBA)

Below are some code samples that I have used to do various things over the years. Most have been written in Microsoft Access, but they are also easily transferable to Excel VBA. If I have used someone else’s code I have tried to give them credit below, but in some cases I may not know where it originated. If you notice your code below and want to be given credit please get in touch using the contact form. Anything that I have created can be freely used without limitation provided you give credit to me and include a link to this site.


Password Protect Excel

Public Sub PasswordProtectExcel(strFile As String, strPassword As String)

On Error GoTo PROC_ERROR
Dim xlApp As Object
Dim xlSheet As Object

Set xlApp = CreateObject(“Excel.Application”)
Set xlSheet = xlApp.Workbooks.Open(strFile).Sheets(1)

With xlApp

‘Password protect the file [OnOpen password]
.Application.DisplayAlerts = False
.Application.ActiveWorkbook.SaveAs fileName:=strFile, Password:=strPassword
.Application.DisplayAlerts = True
.Application.ActiveWorkbook.Save
.Application.ActiveWorkbook.Close
.Quit

End With

Set xlApp = Nothing
Set xlSheet = Nothing

PROC_EXIT:
Exit Sub

PROC_ERROR:
Stop
Resume
MsgBox Err.number & ” – ” & Err.Description
Resume PROC_EXIT

End Sub


Browse a Directory

Option Compare Database

Option Explicit

‘ Credit: Terry Kreft
‘Used to open browser dialogue box so user can choose where to save/open a file to/from

Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Private Declare Function SHGetPathFromIDList Lib “shell32.dll” Alias “SHGetPathFromIDListA” (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib “shell32.dll” Alias “SHBrowseForFolderA” (lpBrowseInfo As BROWSEINFO) As Long

Private Const BIF_RETURNONLYFSDIRS = &H1

Public Function BrowseDirectory(szDialogTitle As String) As String
On Error GoTo Err_BrowseDirectory

Dim x As Long, bi As BROWSEINFO, dwIList As Long
Dim szPath As String, wPos As Integer

With bi
.hOwner = hWndAccessApp
.lpszTitle = szDialogTitle
.ulFlags = BIF_RETURNONLYFSDIRS
End With

dwIList = SHBrowseForFolder(bi)
szPath = Space$(512)
x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)

If x Then
wPos = InStr(szPath, Chr(0))
BrowseDirectory = Left$(szPath, wPos – 1)
Else
BrowseDirectory = “”
End If

Exit_BrowseDirectory:
Exit Function

Err_BrowseDirectory:
MsgBox Err.number & ” – ” & Err.Description
Resume Exit_BrowseDirectory

End Function

Public Function TestBrowseDirectory()
On Error GoTo Err_TestBrowseDirectory

Dim sDirectoryName As String

sDirectoryName = BrowseDirectory(“Please Choose a directory from the directory tree below.”)

If sDirectoryName <> “” Then MsgBox “You selected the ‘” & sDirectoryName & “‘ directory.”, vbInformation

Exit_TestBrowseDirectory:
Exit Function

Err_TestBrowseDirectory:
MsgBox Err.number & ” – ” & Err.Description
Resume Exit_TestBrowseDirectory

End Function


Browse Files

‘ Credit: Carl Tribble
‘.Copyright 1999 Tribble Software.  All rights reserved.
‘.Phone        : (616) 455-2055
‘.E-mail       : carltribble@earthlink.net

Option Compare Database
Option Explicit

Private Declare Function ts_apiGetOpenFileName Lib “comdlg32.dll” _
Alias “GetOpenFileNameA” (tsFN As tsFileName) As Boolean

Private Declare Function ts_apiGetSaveFileName Lib “comdlg32.dll” _
Alias “GetSaveFileNameA” (tsFN As tsFileName) As Boolean

Private Declare Function CommDlgExtendedError Lib “comdlg32.dll” () As Long

Private Type tsFileName
lStructSize As Long
hwndOwner As Long
hInstance As Long
strFilter As String
strCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
strFile As String
nMaxFile As Long
strFileTitle As String
nMaxFileTitle As Long
strInitialDir As String
strTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
strDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

‘ Flag Constants
Public Const tscFNAllowMultiSelect = &H200
Public Const tscFNCreatePrompt = &H2000
Public Const tscFNExplorer = &H80000
Public Const tscFNExtensionDifferent = &H400
Public Const tscFNFileMustExist = &H1000
Public Const tscFNPathMustExist = &H800
Public Const tscFNNoValidate = &H100
Public Const tscFNHelpButton = &H10
Public Const tscFNHideReadOnly = &H4
Public Const tscFNLongNames = &H200000
Public Const tscFNNoLongNames = &H40000
Public Const tscFNNoChangeDir = &H8
Public Const tscFNReadOnly = &H1
Public Const tscFNOverwritePrompt = &H2
Public Const tscFNShareAware = &H4000
Public Const tscFNNoReadOnlyReturn = &H8000
Public Const tscFNNoDereferenceLinks = &H100000

Public Function tsGetFileFromUser( _
Optional ByRef rlngflags As Long = 0&, _
Optional ByVal strInitialDir As String = “”, _
Optional ByVal strFilter As String = “All Files (*.*)” & vbNullChar & “*.*”, _
Optional ByVal lngFilterIndex As Long = 1, _
Optional ByVal strDefaultExt As String = “”, _
Optional ByVal strFilename As String = “”, _
Optional ByVal strDialogTitle As String = “”, _
Optional ByVal fOpenFile As Boolean = True) As Variant

On Error GoTo tsGetFileFromUser_Err
Dim tsFN As tsFileName
Dim strFileTitle As String
Dim fResult As Boolean

‘ Allocate string space for the returned strings.
strFilename = Left(strFilename & String(256, 0), 256)
strFileTitle = String(256, 0)

‘ Set up the data structure before you call the function
With tsFN
.lStructSize = Len(tsFN)
.hwndOwner = Application.hWndAccessApp
.strFilter = strFilter
.nFilterIndex = lngFilterIndex
.strFile = strFilename
.nMaxFile = Len(strFilename)
.strFileTitle = strFileTitle
.nMaxFileTitle = Len(strFileTitle)
.strTitle = strDialogTitle
.flags = rlngflags
.strDefExt = strDefaultExt
.strInitialDir = strInitialDir
.hInstance = 0
.strCustomFilter = String(255, 0)
.nMaxCustFilter = 255
.lpfnHook = 0
End With

‘ Call the function in the windows API
If fOpenFile Then
fResult = ts_apiGetOpenFileName(tsFN)
Else
fResult = ts_apiGetSaveFileName(tsFN)
End If

‘ If the function call was successful, return the FileName chosen
‘ by the user.  Otherwise return “”.  Note, the CancelError property
‘ used by the ActiveX Common Dialog control is not needed.  If the
‘ user presses Cancel, this function will return “”.
If fResult Then
rlngflags = tsFN.flags
tsGetFileFromUser = tsTrimNull(tsFN.strFile)
Else
tsGetFileFromUser = “”
End If

tsGetFileFromUser_End:
On Error GoTo 0
Exit Function

tsGetFileFromUser_Err:
Beep
MsgBox Err.Description, , “Error: ” & Err.number _
& ” in function basBrowseFiles.tsGetFileFromUser”
Resume tsGetFileFromUser_End

End Function

‘ Trim Nulls from a string returned by an API call.

Private Function tsTrimNull(ByVal strItem As String) As String

On Error GoTo tsTrimNull_Err
Dim i As Integer

i = InStr(strItem, vbNullChar)
If i > 0 Then
tsTrimNull = Left(strItem, i – 1)
Else
tsTrimNull = strItem
End If

tsTrimNull_End:
On Error GoTo 0
Exit Function

tsTrimNull_Err:
Beep
MsgBox Err.Description, , “Error: ” & Err.number _
& ” in function basBrowseFiles.tsTrimNull”
Resume tsTrimNull_End

End Function


Change Background Colour for Access Form

Option Compare Database
Option Explicit

‘ Credit:   Stephen Lebans

‘Functions:     SetMDIBackGround(ByVal crColor As Long) As Boolean
‘               RestoreMDIBackground() As Boolean

Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Type SIZEL
cx As Long
cy As Long
End Type

Private Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgblReserved As Byte
End Type

Private Type BITMAPINFOHEADER ’40 bytes
biSize As Long ‘ 40
biWidth As Long ‘ 32
biHeight As Long ‘ 64
biPlanes As Integer ‘1
biBitCount As Integer ‘1
biCompression As Long ‘ERGBCompression
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type

Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(1) As RGBQUAD
End Type

Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type

‘ Logical Brush (or Pattern)
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type

Private Declare Function GetDC Lib “user32” (ByVal hwnd As Long) As Long

Private Declare Function DeleteDC Lib “gdi32” (ByVal hDC As Long) As Long

Private Declare Function apiGetDeviceCaps Lib “gdi32” Alias “GetDeviceCaps” (ByVal hDC As Long, ByVal nIndex As Long) As Long

Private Declare Function CreateSolidBrush Lib “gdi32” (ByVal crColor As Long) As Long

Private Declare Function DeleteObject Lib “gdi32” (ByVal hObject As Long) As Long

Private Declare Function GetStockObject Lib “gdi32” (ByVal nIndex As Long) As Long

Private Declare Function SetClassLong Lib “user32” Alias “SetClassLongA” (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Declare Function FindWindowEx Lib “user32” Alias “FindWindowExA” (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long

Private Declare Function GetWindowRect Lib “user32” (ByVal hwnd As Long, lpRect As RECT) As Long

Private Declare Function InvalidateRect Lib “user32” (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long) As Long

‘ Class field offsets for GetClassLong() and GetClassWord()
Private Const GCL_MENUNAME = (-8)
Private Const GCL_HBRBACKGROUND = (-10)
Private Const GCL_HCURSOR = (-12)
Private Const GCL_HICON = (-14)
Private Const GCL_HMODULE = (-16)
Private Const GCL_CBWNDEXTRA = (-18)
Private Const GCL_CBCLSEXTRA = (-20)
Private Const GCL_WNDPROC = (-24)
Private Const GCL_STYLE = (-26)
Private Const GCW_ATOM = (-32)

‘ Stock Logical Objects
Private Const WHITE_BRUSH = 0
Private Const LTGRAY_BRUSH = 1
Private Const GRAY_BRUSH = 2
Private Const DKGRAY_BRUSH = 3
Private Const BLACK_BRUSH = 4
Private Const Null_BRUSH = 5
Private Const HOLLOW_BRUSH = Null_BRUSH

Private Const CLR_INVALID = &HFFFF

‘ Brush Styles
Private Const BS_SOLID = 0
Private Const BS_Null = 1
Private Const BS_HOLLOW = BS_Null
Private Const BS_HATCHED = 2
Private Const BS_PATTERN = 3
Private Const BS_INDEXED = 4
Private Const BS_DIBPATTERN = 5
Private Const BS_DIBPATTERNPT = 6
Private Const BS_PATTERN8X8 = 7
Private Const BS_DIBPATTERN8X8 = 8

‘  Hatch Styles
Private Const HS_HORIZONTAL = 0              ‘  —–
Private Const HS_VERTICAL = 1                ‘  |||||
Private Const HS_FDIAGONAL = 2               ‘  \\\\\
Private Const HS_BDIAGONAL = 3               ‘  /////
Private Const HS_CROSS = 4                   ‘  +++++
Private Const HS_DIAGCROSS = 5               ‘  xxxxx
Private Const HS_FDIAGONAL1 = 6
Private Const HS_BDIAGONAL1 = 7
Private Const HS_SOLID = 8
Private Const HS_DENSE1 = 9
Private Const HS_DENSE2 = 10
Private Const HS_DENSE3 = 11
Private Const HS_DENSE4 = 12
Private Const HS_DENSE5 = 13
Private Const HS_DENSE6 = 14
Private Const HS_DENSE7 = 15
Private Const HS_DENSE8 = 16
Private Const HS_NOSHADE = 17
Private Const HS_HALFTONE = 18
Private Const HS_SOLIDCLR = 19
Private Const HS_DITHEREDCLR = 20
Private Const HS_SOLIDTEXTCLR = 21
Private Const HS_DITHEREDTEXTCLR = 22
Private Const HS_SOLIDBKCLR = 23
Private Const HS_DITHEREDBKCLR = 24
Private Const HS_API_MAX = 25

Private Const TITLE = “”
Private Const API_TRUE As Long = 1&
‘ Handle to original WINDOWCLASS Brush for MDI window
Private prevHBrush As Long
‘ Handle to our new Brush for the MDI window
Private hBrush As Long
‘ Handle to MDI window
Private HwndMDI As Long

Public Function SetMDIBackGround(ByVal crColor As Long) As Boolean
On Error GoTo Err_SetMDIBackGround

‘ junk var
Dim lngRet As Long

‘ Window Rect
Dim rc As RECT

‘ Grab the Stock WHITE brush
‘ hBrush = GetStockObject(WHITE_BRUSH)
hBrush = CreateSolidBrush(crColor)

‘ find MDIClient first
HwndMDI = FindWindowEx(Application.hWndAccessApp, 0&, “MDIClient”, TITLE)
‘ Get current dimensions
lngRet = GetWindowRect(HwndMDI, rc)

With rc
.Bottom = .Bottom – .Top
.Top = 0
.Right = .Right – .Left
.Left = 0
End With
prevHBrush = SetClassLong(HwndMDI, GCL_HBRBACKGROUND, hBrush)
‘ Force a redraw
Call InvalidateRect(HwndMDI, rc, API_TRUE)
SetMDIBackGround = True

Exit_SetMDIBackGround:
Exit Function

Err_SetMDIBackGround:
FormattedMsgBox Err.number & ” – ” & Err.Description
Resume Exit_SetMDIBackGround

End Function

Public Function RestoreMDIBackground() As Boolean
On Error GoTo Err_RestoreMDIBackground

‘ junk var
Dim lngRet As Long

‘ Window Rect
Dim rc As RECT

‘ Get current dimensions
lngRet = GetWindowRect(HwndMDI, rc)

With rc
.Bottom = .Bottom – .Top
.Top = 0
.Right = .Right – .Left
.Left = 0
End With

hBrush = SetClassLong(HwndMDI, GCL_HBRBACKGROUND, prevHBrush)
‘ Force a redraw
Call InvalidateRect(HwndMDI, rc, API_TRUE)

Call DeleteObject(hBrush)
RestoreMDIBackground = True

Exit_RestoreMDIBackground:
Exit Function

Err_RestoreMDIBackground:
FormattedMsgBox Err.number & ” – ” & Err.Description
Resume Exit_RestoreMDIBackground

End Function


Check for Import Errors

Option Compare Database
Option Explicit

‘A module which is used to check if there are import errors in a specific file, whilst importing multiple files in a loop.
‘You would call the module in the middle of the loop after importing the data to a table.
‘It looks for the existence of a system generated import error log table and outputs it’s contents along with all errors.

Public Function ModCheckForErrors(strFilename As String)

Dim rst As DAO.Recordset
Dim rst2 As DAO.Recordset
Dim strSQL As String
Dim qdf As QueryDef
Dim strTableName As String

strSQL = “SELECT Name FROM MSysObjects WHERE Type=1” ‘Type 5 = queries (incl. sqpt)

Set rst = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)

rst.MoveLast
rst.MoveFirst

Do While Not rst.EOF

strTableName = rst!Name

If InStr(1, strTableName, “ImportE”, vbTextCompare) > 0 Then

AddToLog “c:\temp\SB30594\ImportLog.txt”, Err.number & ” ” & Err.Description & ” Import errors in this file – ” & strFilename

Set rst2 = CurrentDb.OpenRecordset(“select * from ” & strTableName)
With rst2

rst2.MoveLast
rst2.MoveFirst

If rst2.RecordCount > 0 Then

Do While Not rst2.EOF

AddToLog “c:\temp\SB30594\ImportLog.txt”, “Error: ” & rst2!Error & ”   Field: ” & rst2!Field & ”   Row: ” & rst2!Row

rst2.MoveNext

Loop

End If
End With
rst2.Close

DeleteTable strTableName
End If

rst.MoveNext
Loop

Set rst = Nothing
Set rst2 = Nothing

End Function


General Functions

Repeat this header for each function below…

Option Compare Database
Option Explicit
Declare Function IsZoomed Lib “user32” (ByVal hwnd As Long) As Long
Private Const sModule_Name As String = “ModCommonFunctions”

Declare Function ShellExecute Lib “shell32.dll” Alias “ShellExecuteA” (ByVal hwnd As Long, ByVal lpszOp As String, ByVal lpszFile As String, ByVal lpszParams As String, ByVal LpszDir As String, ByVal FsShowCmd As Long) As Long

Private Declare Function GetDesktopWindow Lib “user32” () As Long

Const SW_SHOWNORMAL = 1
Const SE_ERR_FNF = 2&
Const SE_ERR_PNF = 3&
Const SE_ERR_ACCESSDENIED = 5&
Const SE_ERR_OOM = 8&
Const SE_ERR_DLLNOTFOUND = 32&
Const SE_ERR_SHARE = 26&
Const SE_ERR_ASSOCINCOMPLETE = 27&
Const SE_ERR_DDETIMEOUT = 28&
Const SE_ERR_DDEFAIL = 29&
Const SE_ERR_DDEBUSY = 30&
Const SE_ERR_NOASSOC = 31&
Const ERROR_BAD_FORMAT = 11&



Check if Form is Open

Public Function IsFormOpen(Formname)

PROC_DECLARATIONS:
Const sProc_Name  As String = “OpenForm”
Dim dbs As DAO.Database
Dim Frm As Variant
Dim bisopen As Boolean

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:
bisopen = False
Set dbs = CurrentDb

For Each Frm In Forms
If Frm.Name = Formname Then
bisopen = True
End If
Next Frm

IsFormOpen = bisopen

PROC_EXIT:
‘ Perform cleanup code here, set recordsets to nothing, etc.
On Error Resume Next
Set Frm = Nothing
dbs.Close
Exit Function

PROC_ERROR:
Select Case iErrorHandler(Err.Description, Err.number, sProc_Name, sModule_Name)
Case iERROR_DEBUG
Stop
Resume
Case iERROR_RETRY
Resume
Case iERROR_IGNORE
Resume Next
Case iERROR_ABORT
Call CloseApplication
Case Else

MsgBox “Error: ” & Err.Description
End Select
Resume PROC_EXIT

End Function


Check if  form is Maximised

 Public Function IsFormMaximised(Formname)

PROC_DECLARATIONS:
Const sProc_Name  As String = “OpenForm”
Dim dbs As DAO.Database
Dim Frm As Variant
Dim blnMaximised As Boolean

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:
blnMaximised = False
Set dbs = CurrentDb

For Each Frm In Forms
If Frm.Name = Formname Then
If IsZoomed(Frm.hwnd) <> 0 Then
blnMaximised = True
End If
End If
Next Frm

IsFormMaximised = blnMaximised

PROC_EXIT:
‘ Perform cleanup code here, set recordsets to nothing, etc.
On Error Resume Next
Set Frm = Nothing
dbs.Close
Exit Function

PROC_ERROR:
Select Case iErrorHandler(Err.Description, Err.number, sProc_Name, sModule_Name)
Case iERROR_DEBUG
Stop
Resume
Case iERROR_RETRY
Resume
Case iERROR_IGNORE
Resume Next
Case iERROR_ABORT
Call CloseApplication
Case Else

MsgBox “Error: ” & Err.Description
End Select
Resume PROC_EXIT

End Function


Open form (if it isn’t already)

Public Function OpenForm(Formname)

PROC_DECLARATIONS:
Const sProc_Name  As String = “OpenForm”
Dim dbs As DAO.Database
Dim Frm As Variant
Dim bisopen As Boolean

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:
bisopen = False
Set dbs = CurrentDb

For Each Frm In Forms
If Frm.Name = Formname Then
bisopen = True
End If
Next Frm
If bisopen = False Then
DoCmd.OpenForm Formname
End If

PROC_EXIT:
‘ Perform cleanup code here, set recordsets to nothing, etc.
On Error Resume Next
Set Frm = Nothing
dbs.Close
Exit Function

PROC_ERROR:
Select Case iErrorHandler(Err.Description, Err.number, sProc_Name, sModule_Name)
Case iERROR_DEBUG
Stop
Resume
Case iERROR_RETRY
Resume
Case iERROR_IGNORE
Resume Next
Case iERROR_ABORT
Call CloseApplication
Case Else

MsgBox “Error: ” & Err.Description
End Select
Resume PROC_EXIT

End Function


Close the form (if open)

Public Function CloseForm(Formname)

PROC_DECLARATIONS:
Const sProc_Name  As String = “CloseForm”
Dim dbs As DAO.Database
Dim Frm As Variant
Dim bisopen As Boolean

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:
bisopen = False
Set dbs = CurrentDb

For Each Frm In Forms
If Frm.Name = Formname Then
bisopen = True
End If
Next Frm
If bisopen = True Then
DoCmd.Close acForm, Formname, acSaveNo
End If

PROC_EXIT:
‘ Perform cleanup code here, set recordsets to nothing, etc.
On Error Resume Next
Set Frm = Nothing
dbs.Close
Set dbs = Nothing
Exit Function

PROC_ERROR:
Select Case iErrorHandler(Err.Description, Err.number, sProc_Name, sModule_Name)
Case iERROR_DEBUG
Stop
Resume
Case iERROR_RETRY
Resume
Case iERROR_IGNORE
Resume Next
Case iERROR_ABORT
Call CloseApplication
Case Else

MsgBox “Error: ” & Err.Description
End Select
Resume PROC_EXIT

End Function


Is the file locked?

Function FileLocked(strFilename As String) As Boolean
On Error Resume Next
‘ If the file is already opened by another process and the specified type of access is not allowed
‘ the Open operation fails and an error occurs.
Open strFilename For Binary Access Read Write Lock Read Write As #1
Close #1
‘ If an error occurs, the document is currently open.
If Err.number <> 0 Then
FileLocked = True
Err.Clear
End If

End Function


Create a Directory (if it doesn’t already exist)

Public Function CreateDirectory(strPath As String)

PROC_DECLARATIONS:
Const sProc_Name  As String = “CreateDirectory”

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:

If Len(Dir(strPath, vbDirectory)) = 0 Then
MkDir strPath
End If

PROC_EXIT:
‘ Perform cleanup code here, set recordsets to nothing, etc.
On Error Resume Next
Exit Function

PROC_ERROR:
Select Case iErrorHandler(Err.Description, Err.number, sProc_Name, sModule_Name)
Case iERROR_DEBUG ‘Breaks in Debug mode for admin (done through registry settings)
Stop
Resume
Case iERROR_RETRY
Resume
Case iERROR_IGNORE
Resume Next
Case iERROR_ABORT
Call CloseApplication
Case Else

MsgBox “Error: ” & Err.Description
End Select
Resume PROC_EXIT

End Function


Format dates to US date standard

Public Function qd(ByVal dteDate As Date) As String ‘QD = query dates allows date functions to be performed by using US date standard

PROC_DECLARATIONS:
Const sProc_Name  As String = “QD”

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:
qd = Format(dteDate, “mm/dd/yyyy”)

PROC_EXIT:
‘ Perform cleanup code here, set recordsets to nothing, etc.
On Error Resume Next
Exit Function

PROC_ERROR:
Select Case iErrorHandler(Err.Description, Err.number, sProc_Name, sModule_Name)
Case iERROR_DEBUG
Stop
Resume
Case iERROR_RETRY
Resume
Case iERROR_IGNORE
Resume Next
Case iERROR_ABORT
Call CloseApplication
Case Else

MsgBox “Error: ” & Err.Description
End Select
Resume PROC_EXIT

End Function


Get the filename from a full path name

Function GetFilenameFromPath(ByVal strPath As String) As String

If Right$(strPath, 1) <> “\” And Len(strPath) > 0 Then
GetFilenameFromPath = GetFilenameFromPath(Left$(strPath, Len(strPath) – 1)) + Right$(strPath, 1)
End If

End Function

Public Function RenameFiles()

Dim rst As DAO.Recordset
Dim dbs As DAO.Database

Dim objFSO As FileSystemObject
Dim strFilename As String
Dim strNewName As String

Set dbs = CurrentDb()
Set rst = CurrentDb.OpenRecordset(“Select * from tblReportsPendingDelivery”)

With rst
If rst.RecordCount > 0 Then
.MoveFirst
Do While Not rst.EOF

strFilename = rst!File
Set objFSO = New Scripting.FileSystemObject

strNewName = “C:\Temp\CommercialOutput\” & replace(strFilename, “20120810”, “20120813”, 1, 1000)
strFilename = “C:\Temp\CommercialOutput\” & strFilename
objFSO.MoveFile strFilename, strNewName

rst.MoveNext
Loop
End If
End With

On Error Resume Next
rst.Close
Set rst = Nothing
Set dbs = Nothing
End Function


Determine if the active record in the form is the new record

‘ FUNCTION: IsNewRecord()
‘ PURPOSE: ‘   Determines if the record in the active form is the new record.
‘ RETURNS:   True – If the record is the new record.  False – If the record is not the new record.

Public Function IsNewRecord()
Const NO_CURRENT_RECORD = 3021
Dim RetVal
On Error Resume Next

‘ Try to reference the bookmark property of the current record.
RetVal = Screen.ActiveForm.Bookmark

If Err = NO_CURRENT_RECORD Then
IsNewRecord = True
Else
IsNewRecord = False
End If
End Function


Opens a File

Public Function OpenFile(strFilename As String)
PROC_DECLARATIONS:
Const sProc_Name  As String = “Openfile”
Dim Scr_hDC As Long
Dim r As Long
Dim msg As String

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:

r = StartDoc(strFilename)

If r <= 32 Then
‘There was an error
Select Case r
Case SE_ERR_FNF
msg = “File not found”
Case SE_ERR_PNF
msg = “Path not found”
Case SE_ERR_ACCESSDENIED
msg = “Access denied”
Case SE_ERR_OOM
msg = “Out of memory”
Case SE_ERR_DLLNOTFOUND
msg = “DLL not found”
Case SE_ERR_SHARE
msg = “A sharing violation occurred”
Case SE_ERR_ASSOCINCOMPLETE
msg = “Incomplete or invalid file association”
Case SE_ERR_DDETIMEOUT
msg = “DDE Time out”
Case SE_ERR_DDEFAIL
msg = “DDE transaction failed”
Case SE_ERR_DDEBUSY
msg = “DDE busy”
Case SE_ERR_NOASSOC
msg = “No association for file extension”
Case ERROR_BAD_FORMAT
msg = “Invalid EXE file or error in EXE image”
Case Else
msg = “Unknown error”
End Select
MsgBox msg
End If

PROC_EXIT:
‘ Perform cleanup code here, set recordsets to nothing, etc.
On Error Resume Next
Exit Function

PROC_ERROR:
Select Case iErrorHandler(Err.Description, Err.number, sProc_Name, sModule_Name)
Case iERROR_DEBUG
Stop
Resume
Case iERROR_RETRY
Resume
Case iERROR_IGNORE
Resume Next
Case iERROR_ABORT
Call CloseApplication
Case Else

MsgBox “Error: ” & Err.Description
End Select
Resume PROC_EXIT

End Function


‘Used in code above

Function StartDoc(DocName As String) As Long
Dim Scr_hDC As Long
Scr_hDC = GetDesktopWindow()
StartDoc = ShellExecute(Scr_hDC, “Open”, DocName, “”, “C:\”, SW_SHOWNORMAL)

End Function


Check if file exists (return true/false)

Public Function FileExists(strPath As String) As Boolean

PROC_DECLARATIONS:
Const sProc_Name  As String = “CreateDirectory”

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:

If Len(Dir(strPath, vbDirectory)) = 0 Then
FileExists = False
Else
FileExists = True
End If

PROC_EXIT:
‘ Perform cleanup code here, set recordsets to nothing, etc.
On Error Resume Next
Exit Function

PROC_ERROR:
Select Case iErrorHandler(Err.Description, Err.number, sProc_Name, sModule_Name)
Case iERROR_DEBUG ‘Breaks in Debug mode for admin (done through registry settings)
Stop
Resume
Case iERROR_RETRY
Resume
Case iERROR_IGNORE
Resume Next
Case iERROR_ABORT
Call CloseApplication
Case Else

MsgBox “Error: ” & Err.Description
End Select
Resume PROC_EXIT

End Function


Count Distinct

Option Compare Database

Public Function CountDistinct(Expr As String, Domain As String, Optional Criteria As String, Optional bCountDistinct As Boolean) As Variant
On Error GoTo Err_Handler
‘Purpose:   Enhanced DCount() function, with the ability to count distinct.
‘Return:    Number of records. Null on error.
‘Arguments: Expr           = name of the field to count. Use square brackets if the name contains a space.
‘           Domain         = name of the table or query.
‘           Criteria       = any restrictions. Can omit.
‘           bCountDistinct = True to return the number of distinct values in the field. Omit for normal count.
‘Notes:     Nulls are excluded (whether distinct count or not.)
‘           Use “*” for Expr if you want to count the nulls too.
‘           You cannot use “*” if bCountDistinct is True.
‘Examples:  Number of customers who have a region: ECount(“Region”, “Customers”)
‘           Number of customers who have no region: ECount(“*”, “Customers”, “Region Is Null”)
‘           Number of distinct regions: ECount(“Region”, “Customers”, ,True)
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String

‘Initialize to return Null on error.
ECount = Null
Set db = DBEngine(0)(0)

If bCountDistinct Then
‘Count distinct values.
If Expr <> “*” Then             ‘Cannot count distinct with the wildcard.
strSQL = “SELECT ” & Expr & ” FROM ” & Domain & ” WHERE (” & Expr & ” Is Not Null)”
If Criteria <> vbNullString Then
strSQL = strSQL & ” AND (” & Criteria & “)”
End If
strSQL = strSQL & ” GROUP BY ” & Expr & “;”
Set rs = db.OpenRecordset(strSQL)
If rs.RecordCount > 0& Then
rs.MoveLast
End If
ECount = rs.RecordCount     ‘Return the number of distinct records.
rs.Close
End If
Else
‘Normal count.
strSQL = “SELECT Count(” & Expr & “) AS TheCount FROM ” & Domain
If Criteria <> vbNullString Then
strSQL = strSQL & ” WHERE ” & Criteria
End If
Set rs = db.OpenRecordset(strSQL)
If rs.RecordCount > 0& Then
ECount = rs!TheCount        ‘Return the count.
End If
rs.Close
End If

Exit_Handler:
Set rs = Nothing
Set db = Nothing
Exit Function

Err_Handler:
MsgBox Err.Description, vbExclamation, “ECount Error ” & Err.number
Resume Exit_Handler
End Function


 Delete Functions

Option Compare Database
Option Explicit
Private Const sModule_Name As String = “ModDeleteFunctions”

‘Used for Delete Functions (Directory, File, Query, Table and Truncate All Records)



 

Delete all of the files in a directory

Public Function ClearDirectory(strPath As String) ‘Will clear all files within a directory but keep the directory

PROC_DECLARATIONS:
Const sProc_Name  As String = “ClearDirectory”
Dim strTempFile As String
Dim strFilename As String
Dim i As Long

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:

DoCmd.SetWarnings False

i = 0

If Dir(strPath, vbDirectory) <> “” Then
strTempFile = strPath & “\” & Dir(strPath & “\*.*”)
Do While Dir(strPath & “\*.*”) <> “”
strFilename = GetFilenameFromPath(strTempFile)
Kill strTempFile
i = i + 1
AddToLog sProc_Name, ”   => Deleted Temp File ” & i & ” – ” & strFilename
strTempFile = strPath & “\” & Dir(strPath & “\*.*”)
Loop
End If

MsgBox i & ” Temporary files deleted from working directory”, vbOKOnly + vbInformation, “Process Complete”
AddToLog sProc_Name, “Directory Cleared – ” & i & ” Temporary files deleted”

PROC_EXIT:
On Error Resume Next
Exit Function

PROC_ERROR:
MsgBox “Couldn’t delete file ” & (i + 1) & ” – ” & strFilename & vbCrLf & _
“The file is in a locked state… possibly because it is currently open” & vbCrLf & _
“Please close this file and delete the remainder of the directory manually” & vbCrLf & _
“Working Dir: ” & gstrWorkingDir, vbOKOnly + vbCritical, “File Locked”
AddToLog sProc_Name, ” ** Failed ** Unable to delete file ” & (i + 1) & ” – ” & strFilename
Resume PROC_EXIT

End Function


Delete a Query

Public Function DeleteQuery(pMyQuery As String)
‘ Credit: Raskew – www.access-programmers.co.uk

PROC_DECLARATIONS:

Const sProc_Name  As String = “DeleteQuery”
Dim dbs As DAO.Database
Dim qd  As QueryDef
Dim Test As String
Dim strQuery   As String

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:

Set dbs = CurrentDb

strQuery = pMyQuery

‘Does query strQuery exist?
‘If true, delete it;

Test = dbs.QueryDefs(strQuery).Name

‘ Now, we’re ready to delete the query
If Test <> “” Then
DoCmd.SetWarnings False
DoCmd.DeleteObject acQuery, strQuery
DoCmd.SetWarnings True
End If

PROC_EXIT:
‘ Perform cleanup code here, set recordsets to nothing, etc.
On Error Resume Next
dbs.Close
Set dbs = Nothing
Exit Function

PROC_ERROR:
If Err = 3265 Then ‘Table doesn’t exist, exit without doing anything
Resume PROC_EXIT
End If

Select Case iErrorHandler(Err.Description, Err.number, sProc_Name, sModule_Name)
Case iERROR_DEBUG
Stop
Resume
Case iERROR_RETRY
Resume
Case iERROR_IGNORE
Resume Next
Case iERROR_ABORT
Call CloseApplication
Case Else
MsgBox “Error: ” & Err.Description
End Select
Resume PROC_EXIT

End Function


Delete a Table (if it exists)

Public Function DeleteTable(pMyTable As String)
‘ Code from Raskew – www.access-programmers.co.uk

PROC_DECLARATIONS:

Const sProc_Name  As String = “DeleteTable”
Dim dbs      As DAO.Database
Dim tdf      As DAO.TableDef
Dim Test    As String
Dim tName   As String
Dim thisrel As Relation

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:

Set dbs = CurrentDb

tName = pMyTable

‘Does table tName exist?
‘If true, delete it;

Test = dbs.TableDefs(tName).Name
If Err <> 3265 Then
‘**********
‘ Since the delete action will fail if the
‘ table is participating in any relation, first
‘ find and delete existing relations for table.
‘**********
For Each thisrel In dbs.Relations
If thisrel.table = tName Or thisrel.ForeignTable = tName Then
Debug.Print tName & ” | ” & thisrel.Name
dbs.Relations.Delete thisrel.Name
End If
Next thisrel
‘**********
‘ Now, we’re ready to delete the table.
‘**********
DoCmd.SetWarnings False
DoCmd.DeleteObject acTable, tName
DoCmd.SetWarnings True
End If

PROC_EXIT:
On Error Resume Next
dbs.Close
Set dbs = Nothing
Exit Function

PROC_ERROR:
If Err = 3265 Then ‘Table doesn’t exist, exit without doing anything
Resume PROC_EXIT
End If

Select Case iErrorHandler(Err.Description, Err.number, sProc_Name, sModule_Name)
Case iERROR_DEBUG
Stop
Resume
Case iERROR_RETRY
Resume
Case iERROR_IGNORE
Resume Next
Case iERROR_ABORT
Call CloseApplication
Case Else
MsgBox “Error: ” & Err.Description
End Select
Resume PROC_EXIT

End Function


Truncate a table

‘Delete everything in the table but leave the table there

Public Function TruncateTable(strTableName As String)

PROC_DECLARATIONS:

Const sProc_Name  As String = “TruncateTable”
Dim db As DAO.Database
Dim tb As DAO.TableDef
Dim strSQL As String

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:
‘First check if table exists, and if so delete all data in that table

Set db = CurrentDb()
For Each tb In db.TableDefs
If tb.Name = strTableName Then
strSQL = “DELETE ” & strTableName & “.* FROM ” & strTableName & “;”
DoCmd.RunSQL strSQL
Exit For
End If
Next

PROC_EXIT:
‘ Perform cleanup code here, set recordsets to nothing, etc.
On Error Resume Next
db.Close
Set db = Nothing
Exit Function

PROC_ERROR:
Select Case iErrorHandler(Err.Description, Err.number, sProc_Name, sModule_Name)
Case iERROR_DEBUG
Stop
Resume
Case iERROR_RETRY
Resume
Case iERROR_IGNORE
Resume Next
Case iERROR_ABORT
Call CloseApplication
Case Else
MsgBox “Error: ” & Err.Description
End Select
Resume PROC_EXIT

End Function


Error Handler

Option Compare Database
Option Explicit
Public Const QUOTE As String = “”””
Private Const sModule_Name As String = “ModErrorHandler”

Public Function iErrorHandler(ByVal sErr As String, ByVal iErrNo As Double, ByVal sProc_Name As String, ByVal sModule_Name As String) As Integer

Dim iRtn As Integer
Dim strSQL As String
Dim strTempVal As String
Dim Counter As Long

On Error GoTo Err_Trap

Counter = 1
‘Remove quotes from error messages
While Counter <= Len(sErr)
If Mid(sErr, Counter, 1) = Chr(39) Then
Counter = Counter + 1
Else
strTempVal = strTempVal & Mid(sErr, Counter, 1)
Counter = Counter + 1
End If
Wend

strSQL = “insert into tblErrorLog values (‘” & Now() & “‘,'” & strTempVal & “‘,” & iErrNo & “,'” & sProc_Name & “‘,'” & sModule_Name & “‘)”
DoCmd.RunSQL strSQL

AddToLog “** ERROR in Module: ” & sModule_Name & “; Proc: ” & sProc_Name & “**”, iErrNo & “: ” & strTempVal

If GetSetting(“CommercialEBM”, “Admin”, “DebugMode”) = “On” Then
iRtn = 1
FormattedMsgBox “Error” & VBA.Space$(1) & iErrNo & VBA.Space$(1) & “‘” & sErr & “‘” & vbCrLf & “Occured in Procedure” & VBA.Space$(1) & sProc_Name & VBA.Space$(1) & “in Module” & VBA.Space$(1) & sModule_Name & vbCrLf, vbOKOnly, “Error in Application”
Else:
Screen.MousePointer = 0
iRtn = FormattedMsgBox(“Error” & VBA.Space$(1) & iErrNo & VBA.Space$(1) & “‘” & sErr & “‘” & vbCrLf & “Occured in Procedure” & VBA.Space$(1) & sProc_Name & VBA.Space$(1) & “in Module” & VBA.Space$(1) _
& sModule_Name & vbCrLf, _
vbAbortRetryIgnore + vbCritical + vbDefaultButton2, _
“Error in Application”)
End If

Err_Exit:
iErrorHandler = iRtn
Exit Function

Err_Trap:
FormattedMsgBox “Error” & VBA.Space$(1) & CStr(VBA.Err) & VBA.Space$(1) & VBA.Error & VBA.Space$(1) & “occured in Procedure iErrorHandler in Module ModErrorHandler”, _
vbOKOnly + vbCritical, “Error in Application”
Resume Err_Exit

End Function


Close Application

Public Sub CloseApplication()
‘ close the application and exit access
On Error Resume Next
DoCmd.Quit acQuitSaveNone
End
End Sub


Export to Multiple Excel Workbooks and Worksheets

Option Compare Database

Public Function OutputManaged() ‘Creates a Spreadsheet for every area manager and a worksheet for every RM under that manager.
PROC_DECLARATIONS:
Dim dbs As Database
Dim rst As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim qdf2 As DAO.QueryDef
Dim qdf3 As DAO.QueryDef
Dim strWorksheetName As String
Dim i As Integer
Dim intPercent As Integer
Dim strRM As String
Dim strAM As String
Dim strExcelPWD As String
Dim strPassword As String
Dim strExcel As String
Dim strSQL As String
Dim lngRecordCount As Long

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:

Set dbs = CurrentDb
With dbs
Set rst = CurrentDb.OpenRecordset(“qsptManaged”)
With rst
rst.MoveLast
rst.MoveFirst
i = 0
If rst.RecordCount > 0 Then

Do While Not rst.EOF

strAM = RemoveSpaces(!AM_Name)
strAM2 = !AM_Name
strRM = RemoveSpaces(!RM_Name)

Debug.Print “outputting ” & strAM & ” – ” & strRM

strExcel = “C:\TEMP\Jade\Managed_” & strAM & “.xls”
strExcelPWD = “C:\TEMP\Jade\Managed_” & strAM & “_PWD.xls”

Set qdf2 = dbs.QueryDefs(“qsptManaged_IndividualRM”)
qdf2.SQL = “SELECT DISTINCT a.n_clg, a.n_cust, a.id_post, a.n_sbch_dmcl AS bsb, a.nm_01, a.nm_firstname, a.nm_surname, a.ad_email,CASE WHEN c.email Is Not Null THEN ‘Y’ Else ‘N’ END As invalid_email_march_survey FROM jibba_temp_all a, comm_sb25162_managed b,cpt.email_load_tb c WHERE a.ad_email = c.email(+) AND a.id_post = b.id_post AND ” & _
“a.id_post not IN (‘L0808′,’L0809′,’L0810′,’L0811′,’L0812′,’L0813′,’W0141’) AND b.AM_NAME = ‘” & !AM_Name & “‘ and b.RM_NAME = ‘” & !RM_Name & “‘”

Set qdf = dbs.CreateQueryDef(strRM)
qdf.SQL = “SELECT n_clg, N_CUST, ID_POST, BSB, NM_01, NM_FIRSTNAME, NM_SURNAME, AD_EMAIL, INVALID_EMAIL_MARCH_SURVEY FROM qsptManaged_IndividualRM;”
qdf.Close
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel7, strRM, strExcel, True
dbs.QueryDefs.Delete strRM

.MoveNext

If rst.EOF = True Then GoTo PROC_JUMP
If (strAM <> Nz(RemoveSpaces(!AM_Name), “bob”)) Then

PROC_JUMP:
‘Add output summary code here before calling the formatting.
dbs.QueryDefs.Delete “SUMMARY”
Set qdf3 = dbs.CreateQueryDef(“SUMMARY”)
strSQL = “select * from ManagedSummary WHERE AM_NAME = ‘” & strAM2 & “‘;”
qdf3.SQL = strSQL
strWorksheetName = “SUMMARY”
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel7, strWorksheetName, strExcel, True

Debug.Print “Formatting Excel”
FormatExcel (strExcel)

strPassword = DFirst(“[password]”, “tblManaged”, “[AM_NAME]='” & strAM2 & “‘”)

PasswordProtectExcel strExcel, strPassword

End If

i = i + 1
Loop

End If
End With
End With

MsgBox “Completed Outputting”, vbOKOnly, “Process Complete”

PROC_EXIT:
On Error Resume Next
Set qdf = Nothing
Set qdf2 = Nothing
Set qdf3 = Nothing
rst.Close
Set rst = Nothing
Set dbs = Nothing
Exit Function

PROC_ERROR:

MsgBox Err.number & ” ” & Err.Description
Stop
Resume
Resume PROC_EXIT

End Function


Extract Table Profiles

Option Compare Database
Option Explicit

Private Const sModule_Name As String = “ModProfileColumns”

Public Function ProfileColumns()

PROC_DECLARATIONS:
Const sProc_Name  As String = “ProfileColumns”
Dim dbs As DAO.Database
Dim rst1 As DAO.Recordset
Dim rst2 As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim strProfileSQL As String
Dim strInsertSQL As String
Dim strFieldValue As String
Dim i As Integer

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:

Set dbs = CurrentDb
Set qdf = dbs.QueryDefs(“qsptGeneric”)

gstrLogFile = “<Pathname/filename>”

i = 0

‘1st loop is to get sql for profiling a column (containing the word “desc”,”Flag”,”Code” or “Name”)
Set rst1 = CurrentDb.OpenRecordset(“SELECT * FROM tblTablesAndColumns”)
With rst1
rst1.MoveLast
rst1.MoveFirst

If rst1.RecordCount > 0 Then

Do While Not rst1.EOF

‘—————————————————————————————

strProfileSQL = rst1!SQL

‘2nd loop is created to get results of profile sql and pass profile into a table called tblTableColumnProfile

qdf.SQL = strProfileSQL
‘DoCmd.RunSQL strProfileSQL

AddToLog “ModProfileColumns”, strProfileSQL

Set rst2 = CurrentDb.OpenRecordset(“select * from qsptGeneric”)
With rst2
rst2.MoveLast
rst2.MoveFirst

‘Don’t want to get too many values so limit to records < 100
If rst2.RecordCount >= 100 Then
AddToLog “ModProfileColumns”, rst1!table_name & “.” & rst1!Column_name & ” has too many values: ” & rst2.RecordCount
End If

If rst2.RecordCount > 0 And rst2.RecordCount < 100 Then

Do While Not rst2.EOF

strFieldValue = EncodeString(Nz(rst2!Field_Value, “<NULL>”))
strInsertSQL = “insert into tblTableColumnProfile(Profile_Date, Table_Name, Column_Name, Field_Value, Value_Count) values (‘” & Now() & “‘,'” & rst1!table_name & “‘,'” & rst1!Column_name & “‘,'” & strFieldValue & “‘,” & rst2!Total_Recs & “)”
DoCmd.RunSQL strInsertSQL

If Nz(rst2!Field_Value, “zzz”) = “zzz” Then
AddToLog “** Null Value **: ModProfileColumns”, strProfileSQL
End If

rst2.MoveNext

Loop

End If
End With

‘—————————————————————————————

rst1.MoveNext
i = i + 1 ‘Used for Debug progress

Debug.Print “Running Query ” & i & ” of ” & rst1.RecordCount
AddToLog “ModExtractTableProfiles”, “Running Query ” & i & ” of ” & rst1.RecordCount

Loop

End If
End With

qdf.Close

PROC_EXIT:
On Error Resume Next
DoCmd.SetWarnings True
Set qdf = Nothing
rst1.Close
Set rst1 = Nothing
rst2.Close
Set rst2 = Nothing
Set dbs = Nothing

Exit Function

PROC_ERROR:
MsgBox “Error: ” & Err.Description
AddToLog “**ERROR** ModProfileColumns”, Err.number & “: ” & Err.Description
Stop
Resume
‘Resume PROC_EXIT

End Function’


Check Table Field Lengths

Option Compare Database
Option Explicit

Private Const sModule_Name As String = “ModFieldLengths”

Public Function FieldLengths()

PROC_DECLARATIONS:
Const sProc_Name  As String = “ProfileColumns”
Dim dbs As DAO.Database
Dim rst1 As DAO.Recordset
Dim rst2 As DAO.Recordset
Dim qdf As DAO.QueryDef
Dim strProfileSQL As String
Dim strInsertSQL As String
Dim strFieldValue As String
Dim i As Integer

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:

Set dbs = CurrentDb
Set qdf = dbs.QueryDefs(“qsptGeneric”)

gstrLogFile = “<Pathname/filename>”

i = 0

‘1st loop is to get sql for profiling a column (containing the word “desc”,”Flag”,”Code” or “Name”)
Set rst1 = CurrentDb.OpenRecordset(“SELECT * FROM tblMaxFieldLength”)
With rst1
rst1.MoveLast
rst1.MoveFirst

If rst1.RecordCount > 0 Then

Do While Not rst1.EOF

‘—————————————————————————————

strProfileSQL = rst1!SQL

‘2nd loop is created to get results of profile sql and pass profile into a table called tblTableColumnProfile

qdf.SQL = strProfileSQL

AddToLog “ModFieldLengths”, strProfileSQL

Set rst2 = CurrentDb.OpenRecordset(“select * from qsptGeneric”)
With rst2
rst2.MoveLast
rst2.MoveFirst

If rst2.RecordCount > 0 Then

Do While Not rst2.EOF

strFieldValue = EncodeString(Nz(rst2!Field_Value, “<NULL>”))
strInsertSQL = “insert into tblTableColumnLengthResults(Profile_Date, Table_Name, Column_Name, MaxPossLength, MaxActualLength, ExampleRecord) values (‘” & Now() & “‘,'” & rst1!table_name & “‘,'” & rst1!Column_name & “‘,” & rst2!max_poss_field_length & “,” & rst2!max_actual_field_length & “,'” & rst2!Example_Record & “‘)”
DoCmd.RunSQL strInsertSQL

If Nz(rst2!Example_Record, “zzz”) = “zzz” Then
AddToLog “** Null Value **: ModFieldLengths”, strProfileSQL
End If

rst2.MoveNext

Loop

End If
End With

‘—————————————————————————————

rst1.MoveNext
i = i + 1 ‘Used for Debug progress

Debug.Print “Running Query ” & i & ” of ” & rst1.RecordCount
AddToLog “ModFieldLengths”, “Running Query ” & i & ” of ” & rst1.RecordCount

Loop

End If
End With

qdf.Close

PROC_EXIT:
On Error Resume Next
DoCmd.SetWarnings True
Set qdf = Nothing
rst1.Close
Set rst1 = Nothing
rst2.Close
Set rst2 = Nothing
Set dbs = Nothing

Exit Function

PROC_ERROR:
MsgBox “Error: ” & Err.Description
AddToLog “**ERROR** ModProfileColumns”, Err.number & “: ” & Err.Description
Stop
Resume
‘Resume PROC_EXIT

End Function


Iterate through a directory and collect all filenames

Dim fso As Scripting.FileSystemObject

Public Function StartListing()
Dim fso As Scripting.FileSystemObject
Dim TopFolderName As String
Dim TopFolderObj As Scripting.Folder

TopFolderName = Forms!frmMain.txtDirectory
If fso Is Nothing Then
Set fso = New Scripting.FileSystemObject
End If

TruncateTable (“tblfiles”)

Set TopFolderObj = fso.GetFolder(TopFolderName)

LoopThroughFiles (TopFolderName)

ListSubFolders OfFolder:=TopFolderObj

Set fso = Nothing

End Function

Public Function ListSubFolders(OfFolder As Scripting.Folder)

Dim SubFolder As Scripting.Folder

For Each SubFolder In OfFolder.SubFolders

ListSubFolders OfFolder:=SubFolder
LoopThroughFiles (SubFolder)

Next SubFolder

End Function

Public Function LoopThroughFiles(strSubfolder As String)
Dim strFile As String
strFile = Dir(strSubfolder & “\Application*.csv”)
Do While Len(strFile) > 0
Debug.Print strSubfolder & “\” & strFile

strSQL = “insert into tblfiles values (‘” & strSubfolder & “‘,'” & strFile & “‘)”
DoCmd.RunSQL strSQL

strFile = Dir
Loop

strFile = Dir(strSubfolder & “\Party*.csv”)
Do While Len(strFile) > 0

Forms!frmMain.lblStatus.Caption = ” Collecting filenames from ” & strSubfolder
Forms!frmMain.Repaint

strSQL = “insert into tblfiles values (‘” & strSubfolder & “‘,'” & strFile & “‘)”
DoCmd.RunSQL strSQL

strFile = Dir
Loop
End Function


Get file record count

Option Compare Database

Public Function GetFileRecordCount(strFilename As String) As Double
Const BUFSIZE As Long = 100000
Dim T0 As Single
Dim LfAnsi As String
Dim FileBytes As Long
Dim BytesLeft As Long
Dim Buffer() As Byte
Dim strBuffer As String
Dim BufPos As Long
Dim LineCount As Long

Close #100

T0 = Timer()
LfAnsi = StrConv(vbLf, vbFromUnicode)
Open strFilename For Binary Access Read As #100
FileBytes = LOF(100)
ReDim Buffer(BUFSIZE – 1)
BytesLeft = FileBytes
Do Until BytesLeft = 0
If BufPos = 0 Then
If BytesLeft < BUFSIZE Then ReDim Buffer(BytesLeft – 1)
Get #100, , Buffer
strBuffer = Buffer ‘Binary copy of bytes.
BytesLeft = BytesLeft – LenB(strBuffer)
BufPos = 1
End If
Do Until BufPos = 0
BufPos = InStrB(BufPos, strBuffer, LfAnsi)
If BufPos > 0 Then
LineCount = LineCount + 1
BufPos = BufPos + 1
End If
Loop
Loop
Close #100
‘Add 1 to LineCount if last line of your files do not
‘have a trailing CrLf.
GetFileRecordCount = LineCount
End Function


Determine File Type

Option Explicit

Public Enum abCharsets
abError = 0
abANSI = 1
abUnicode = 2
abUnicodeBigEndian = 3
abUTF8 = 4
ebUnknown = 5
End Enum

Public Function ReturnCharset(ByVal filePath As String, Optional verifyANSI As Boolean = True) As abCharsets
Const bytByte0Unicode_c As Byte = 255
Const bytByte1Unicode_c As Byte = 254
Const bytByte0UnicodeBigEndian_c As Byte = 254
Const bytByte1UnicodeBigEndian_c As Byte = 255
Const bytByte0UTF8_c As Byte = 239
Const bytByte1UTF8_c As Byte = 187
Const bytByte2UTF8_c As Byte = 191
Const lngByte0 As Long = 0
Const lngByte1 As Long = 1
Const lngByte2 As Long = 2
Dim bytHeader() As Byte
Dim eRtnVal As abCharsets
On Error GoTo Err_Hnd
bytHeader() = GetFileBytes(filePath, lngByte2)
Select Case bytHeader(lngByte0)
Case bytByte0Unicode_c
If bytHeader(lngByte1) = bytByte1Unicode_c Then
eRtnVal = abCharsets.abUnicode
End If
Case bytByte0UnicodeBigEndian_c
If bytHeader(lngByte1) = bytByte1UnicodeBigEndian_c Then
eRtnVal = abCharsets.abUnicodeBigEndian
End If
Case bytByte0UTF8_c
If bytHeader(lngByte1) = bytByte1UTF8_c Then
If bytHeader(lngByte2) = bytByte2UTF8_c Then
eRtnVal = abCharsets.abUTF8
End If
End If
End Select
If Not CBool(eRtnVal) Then
If verifyANSI Then
If IsANSI(filePath) Then
eRtnVal = abCharsets.abANSI
Else
eRtnVal = abCharsets.ebUnknown
End If
Else
eRtnVal = abCharsets.abANSI
End If
End If
exit_proc:
On Error Resume Next
Erase bytHeader
ReturnCharset = eRtnVal
Exit Function
Err_Hnd:
eRtnVal = abCharsets.abError
Resume exit_proc
End Function

Private Function IsANSI(ByVal filePath As String) As Boolean
Const lngKeyCodeNullChar_c As Long = 0
Dim bytFile() As Byte
Dim lngIndx As Long
Dim lngUprBnd As Long
bytFile = GetFileBytes(filePath)
lngUprBnd = UBound(bytFile)
For lngIndx = 0 To lngUprBnd
If bytFile(lngIndx) = lngKeyCodeNullChar_c Then
Exit For
End If
Next
Erase bytFile
IsANSI = (lngIndx > lngUprBnd)
End Function

Public Function GetFileBytes(ByVal path As String, Optional ByVal truncateToByte As Long = -1) As Byte()
Dim lngFileNum As Long
Dim bytRtnVal() As Byte
If truncateToByte < 0 Then
truncateToByte = FileLen(path) – 1
End If
lngFileNum = FreeFile
If CheckFileExists(path) Then
Open path For Binary Access Read As lngFileNum
ReDim bytRtnVal(truncateToByte) As Byte
Get lngFileNum, , bytRtnVal
Close lngFileNum
End If
GetFileBytes = bytRtnVal
Erase bytRtnVal
End Function

Public Function CheckFileExists(ByVal filePath As String) As Boolean
CheckFileExists = CBool(LenB(Dir(filePath, vbHidden + vbNormal + vbSystem + vbReadOnly + vbArchive)))
End Function
Public Function CharsetToString(ByVal value As abCharsets) As String
Dim strRtnVal As String
Select Case value
Case abCharsets.abANSI
strRtnVal = “us-ascii”
Case abCharsets.abUTF8
strRtnVal = “utf-8”
Case Else
strRtnVal = “Unicode”
End Select
CharsetToString = strRtnVal
End Function


Format Excel

QuickTipThis is one of my most used and valued functions. It will format anything that you output to Excel. You call the function with a spreadsheet name and it will iterate through the worksheets and format headers (bold, grey background and blue font), autofit columns, add borders, auto-filters, and freeze panes. It will do it based on whatever is populated on the worksheet. Just stick it in a module and call it with full filename and path.

 

Option Compare Database

Public Function FormatExcel(strFilename As String)

‘This code formats each workbook.
‘Including Borders, bolded headings, Autofit columns, AutoFilter and highlighted input cells, as well as freeze panes

PROC_DECLARATIONS:
Const sProc_Name  As String = “FormatExcel”
Dim objExcel As Object
Dim objWorkbook As Object
Dim i As Integer
Dim iRow As Integer
Dim iCol As Integer
Dim ColLetter As String

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:

Set objExcel = CreateObject(“EXCEL.APPLICATION”)
Set objWorkbook = objExcel.Workbooks.Open(strFilename)

With objExcel

objExcel.DisplayAlerts = False

With objExcel.Workbooks(.Workbooks.Count)

For i = 1 To .Worksheets.Count

iRow = 1
While objWorkbook.Sheets(i).Cells(iRow, 1) <> “”
iRow = iRow + 1
Wend
iCol = 1
While objWorkbook.Sheets(i).Cells(1, iCol) <> “”
iCol = iCol + 1
Wend

objWorkbook.Sheets(i).Select

‘Range(StartAddress).Resize(NumberOfRows, NumberOfColumns).Select
objExcel.Range(“A1”, objExcel.Cells(1, iCol)).Select
objExcel.Range(“A1”, objExcel.Cells(1, iCol)).Font.ColorIndex = 5
objExcel.Range(“A1”, objExcel.Cells(1, iCol)).Interior.ColorIndex = 15
objExcel.Range(“A1”, objExcel.Cells(iRow, iCol)).Select
objExcel.Range(“A1”, objExcel.Cells(iRow, iCol)).Name = “Verdana”
objWorkbook.Sheets(i).Cells.EntireColumn.AutoFit ‘AutoFit column contents
objExcel.Range(“A1”, objExcel.Cells(1, iCol)).Borders.Weight = 2 ‘Add borders

‘Add Autofilter
objExcel.Range(“A1”, objExcel.Cells(iRow – 1, iCol)).Select
objExcel.Range(“A1”).AutoFilter

objExcel.Range(“A2”, objExcel.Cells(2, iCol)).Select
objExcel.ActiveWindow.FreezePanes = False
objExcel.ActiveWindow.FreezePanes = True

objExcel.Range(“A1”).Select ‘Leave it in cell A1 to finish

Next i
End With

.Save
objWorkbook.Close
Set objWorkbook = Nothing

End With

PROC_EXIT:
‘ Perform cleanup code here, set recordsets to nothing, etc.
On Error Resume Next
Set objExcel = Nothing
Exit Function

PROC_ERROR:
If Err = 3051 Then
MsgBox “One of the spreadsheets used may be opened exclusively by someone else.” & vbCrLf & _
“Ask them to close it and then click ok when you are ready to proceed”, vbOKOnly
Resume
End If

Select Case iErrorHandler(Err.Description, Err.number, sProc_Name, sModule_Name)
Case iERROR_DEBUG
Stop
Resume
Case iERROR_RETRY
Resume
Case iERROR_IGNORE
Resume Next
Case iERROR_ABORT
Call CloseApplication
Case Else
‘ Add “last-ditch” error handler.
MsgBox “Error: ” & Err.Description
End Select
Resume PROC_EXIT

End Function


Generate a Strong Password

Option Compare Database

‘Credit: Alan Westwood

Public Function GeneratePWD() As String
‘******************************************************************
‘* Generate an 8 character pseudo random password in the format
‘* [A-Z][a-z][special char][0-9][special char][A-Z][a-z][0-9]
‘* This gives 24,174,030,400 combinations to guess at.
‘******************************************************************
Dim i As Integer
Dim iSlot As Integer
Dim sSigns As String
Dim sPwd As String
Dim dblSeed As Double

dblSeed = Timer * CDbl(Date)

sPwd = “”

Randomize dblSeed
sPwd = Chr(Int((90 – 65) * Rnd + 65)) ‘A-Z
dblSeed = dblSeed * CDbl(Date)
Randomize dblSeed
sPwd = sPwd & Chr(Int((57 – 48) * Rnd + 48)) ‘0-9
dblSeed = dblSeed * CDbl(Date)
Randomize dblSeed
sPwd = sPwd & Chr(Int((57 – 48) * Rnd + 48)) ‘0-9
dblSeed = dblSeed * CDbl(Date)
Randomize dblSeed
sPwd = sPwd & Chr(Int((57 – 48) * Rnd + 48)) ‘0-9
dblSeed = dblSeed * CDbl(Date)
Randomize dblSeed
sPwd = sPwd & Chr(Int((57 – 48) * Rnd + 48)) ‘0-9
dblSeed = dblSeed * CDbl(Date)
Randomize dblSeed
sPwd = sPwd & Chr(Int((90 – 65) * Rnd + 65)) ‘A-Z
dblSeed = dblSeed * CDbl(Date)
Randomize dblSeed
sPwd = sPwd & Chr(Int((90 – 65) * Rnd + 65)) ‘A-Z
dblSeed = dblSeed * CDbl(Date)
Randomize dblSeed
sPwd = sPwd & Chr(Int((57 – 48) * Rnd + 48)) ‘0-9

GeneratePWD = sPwd

End Function


Formatted Messagebox

Option Compare Database

Private Const sModule_Name As String = “ModMsgbox”
‘Allows a message box to display more characters than the default message box

Function FormattedMsgBox( _
Prompt As String, _
Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional TITLE As String = vbNullString, _
Optional HelpFile As Variant, _
Optional Context As Variant) _
As VbMsgBoxResult
If IsMissing(HelpFile) Or IsMissing(Context) Then
FormattedMsgBox = Eval(“MsgBox(“”” & Prompt & _
“””, ” & Buttons & “, “”” & TITLE & “””)”)
Else
FormattedMsgBox = Eval(“MsgBox(“”” & Prompt & _
“””, ” & Buttons & “, “”” & TITLE & “””, “”” & _
HelpFile & “””, ” & Context & “)”)
End If
End Function


Call Password Generator and update password for every record in a table

Option Compare Database

Public Function CPIDAndPWD()
‘Updates passwords for every cpid in tblCPIDAndPWD

Dim strPassword As String
Dim dbs As DAO.Database
Dim rstCPIDAndPWD As DAO.Recordset

Set dbs = CurrentDb()

Set rstCPIDAndPWD = dbs.OpenRecordset(“tblCPIDAndPWD”)

With rstCPIDAndPWD
.MoveFirst
Do While Not rstCPIDAndPWD.EOF
.Edit
!Password = GeneratePWD()
.Update
.MoveNext
Loop
rstCPIDAndPWD.Close
End With

Set dbs = Nothing
Set rstCPIDAndPWD = Nothing

MsgBox “Done”

End Function


Remove Spaces from String

Option Compare Database

Public Function RemoveSpaces(strInput As String)
‘ Removes all spaces from a string of text… and “/” forward slashes
test1:
If InStr(strInput, ” “) = 0 Then
RemoveSpaces = strInput
Else
strInput = Left(strInput, InStr(strInput, ” “) – 1) & Right(strInput, Len(strInput) – InStr(strInput, ” “))
GoTo test1
End If

test2:
If InStr(strInput, “/”) = 0 Then
RemoveSpaces = strInput
Else
strInput = Left(strInput, InStr(strInput, “/”) – 1) & Right(strInput, Len(strInput) – InStr(strInput, “/”))
GoTo test2
End If
End Function


Right Pad String

Option Explicit
Dim x As Integer
Dim PadLength As Integer

‘=====================================================================

‘The following function will right pad a string with a specified
‘character. It accepts a base string which is to be right padded with
‘characters, a character to be used as the pad character, and a
‘length which specifies the total length of the padded result.

‘=====================================================================

Function Rpad(MyValue As String, MyPadCharacter As String, MyPaddedLength As Integer)
Rpad = MyValue & String(MyPaddedLength – Len(MyValue), MyPadCharacter)
End Function


Run an executable or batch file

– Looks for the handle and waits for job to finish

Private Const sModule_Name As String = “ModRunDOSExecutable”
‘The following is Code from Kris, a Software Engineer from Phoenix, AZ USA
‘Additional code from Heulsa, Quebec/Canada
‘Both came from Website: CodeGuru.com
‘I have added my own changes so that it can be executed as a stand-alone function
‘You would run code by calling the function like follows:
‘RunDOSExecutable “c:\temp\Executable.bat”, “c:\temp\Log.txt”

Option Explicit

‘//public Constants
Public Const NORMAL_PRIORITY_CLASS = &H20&
Public Const INFINITE = -1&

‘//public Types
Public Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type

Public Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type

‘//API Declarations
Public Declare Function WaitForSingleObject Lib “kernel32” (ByVal _
hHandle As Long, ByVal dwMilliseconds As Long) As Long

Public Declare Function CreateProcessA Lib “kernel32” (ByVal _
lpApplicationName As Long, ByVal lpCommandLine As String, ByVal _
lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _
lpStartupInfo As STARTUPINFO, lpProcessInformation As _
PROCESS_INFORMATION) As Long

Public Declare Function CloseHandle Lib “kernel32” (ByVal _
hObject As Long) As Long

Private Const STARTF_USESHOWWINDOW = 1
Private Const SW_HIDE = 0

Public Function RunDOSExecutable(AppToRun As String, Optional ByVal Logfile As String)
‘ AppToRun is used for DOS executable name, which must be a full path to Bat or Exe file
‘ Logfile is used to capture the outcome of running the executable
‘ The “/C” tells Windows to Run The Command then Terminate

PROC_DECLARATIONS:
Const sProc_Name  As String = “RunDOSExecutable”
Dim cmdline As String

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:
‘//Build Command string
If Logfile = “” Then
Else: Logfile = ” > ” & Logfile
End If

cmdline = AppToRun & ” /C” & Logfile
DoCmd.Hourglass True

‘//Shell App And Wait for It to Finish
ExecCmd cmdline, True
DoCmd.Hourglass False

PROC_EXIT:
‘ Perform cleanup code here, set recordsets to nothing, etc.
On Error Resume Next
Exit Function

PROC_ERROR:
Select Case iErrorHandler(Err.Description, Err.number, sProc_Name, sModule_Name)
Case iERROR_DEBUG
Stop
Resume
Case iERROR_RETRY
Resume
Case iERROR_IGNORE
Resume Next
Case iERROR_ABORT
Call CloseApplication
Case Else

MsgBox “Error: ” & Err.Description
End Select
Resume PROC_EXIT

End Function


Public Function ExecCmd(ByVal cmdline As String, Optional ByVal HideWindow As Boolean = False) As Long
PROC_DECLARATIONS:
Const sProc_Name  As String = “ExecCmd”
Dim Proc As PROCESS_INFORMATION
Dim start As STARTUPINFO
Dim ReturnValue As Integer

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:
If (HideWindow) Then
start.dwFlags = STARTF_USESHOWWINDOW
start.wShowWindow = SW_HIDE
End If

‘//Initialize The STARTUPINFO Structure
start.cb = Len(start)

‘//Start The Shelled Application
ReturnValue = CreateProcessA(0&, cmdline, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, start, Proc)

‘//Wait for The Shelled Application to Finish
Do
ReturnValue = WaitForSingleObject(Proc.hProcess, 0)
DoEvents
Loop Until ReturnValue <> 258

‘//Close Handle to Shelled Application
ReturnValue = CloseHandle(Proc.hProcess)

PROC_EXIT:
‘ Perform cleanup code here, set recordsets to nothing, etc.
On Error Resume Next
Exit Function

PROC_ERROR:
Select Case iErrorHandler(Err.Description, Err.number, sProc_Name, sModule_Name)
Case iERROR_DEBUG
Stop
Resume
Case iERROR_RETRY
Resume
Case iERROR_IGNORE
Resume Next
Case iERROR_ABORT
Call CloseApplication
Case Else

MsgBox “Error: ” & Err.Description
End Select
Resume PROC_EXIT

End Function


Check for funny characters in a file

Option Compare Database
‘Module will look through a flat file and if there are funny characters it will remove them.
‘Will also count occurences of each and write to a log file.

Sub ReadLines()

Dim sInput As String
Dim i As Long

On Error GoTo PROC_ERROR

Open “<Pathname/filename>” For Input As #1

Do While Not EOF(1)
Input #1, sInput
CheckForFunnyCharsInFile sInput

If ((i – 1) Mod (10000) = 0) Then
AddToSearchLog “Checking record ” & i
Debug.Print “Checking record ” & i
End If
i = i + 1
Loop

Close #1

Exit Sub

PROC_ERROR:
MsgBox Err.number & “: ” & Err.Description
Stop
Resume

End Sub


Check for certain ASCII characters in a file

Public Function CheckForFunnyCharsInFile(strFileRowVal As String) As String

Dim x As Long

If (StringCountOccurrences(strFileRowVal, “|”, vbTextCompare)) >= 39 Then AddToSearchLog “Mbr_Acc_No: ” & Left(strFileRowVal, InStr(1, strFileRowVal, “|”) – 1) & ” has more than 39 Pipes in the row”

For x = 1 To Len(strFileRowVal)
If Asc(Mid$(strFileRowVal, x, 1)) < 32 Or Asc(Mid$(strFileRowVal, x, 1)) >= 127 Then
AddToSearchLog “Mbr_Acc_No: ” & Left(strFileRowVal, InStr(1, strFileRowVal, “|”) – 1) & ” has ASCII character ” & Asc(Mid$(strFileRowVal, x, 1)) & ” in its row.”
Debug.Print “Mbr_Acc_No: ” & Left(strFileRowVal, InStr(1, strFileRowVal, “|”) – 1) & ” has ASCII character ” & Asc(Mid$(strFileRowVal, x, 1)) & ” in its row.”
End If
Next x

End Function


Count the number of occurrences of a character in a string

Function StringCountOccurrences(strText As String, strFind As String, _
Optional lngCompare As VbCompareMethod) As Long
Dim lngPos As Long
Dim lngTemp As Long
Dim lngCount As Long
If Len(strText) = 0 Then Exit Function
If Len(strFind) = 0 Then Exit Function
lngPos = 1
Do
lngPos = InStr(lngPos, strText, strFind, lngCompare)
lngTemp = lngPos
If lngPos > 0 Then
lngCount = lngCount + 1
lngPos = lngPos + Len(strFind)
End If
Loop Until lngPos = 0
StringCountOccurrences = lngCount
End Function


Write to Logfile

Public Function AddToSearchLog(strText As String)

PROC_DECLARATIONS:
Const sProc_Name  As String = “AddToLog”

PROC_START:
On Error GoTo PROC_ERROR

PROC_MAIN:

On Error Resume Next

If Len(Dir(“<Pathname/filename>”)) = 0 Then Call CreateLogFile

Open “<Pathname/filename>” For Append As #2
Print #2, Now() & ” – ” & strText
Close #2

PROC_EXIT:
On Error Resume Next
Exit Function

PROC_ERROR:
MsgBox “Error: ” & Err.Description
Stop
Resume

End Function


Create a Logfile

Public Function CreateLogFile()

Dim fso As Object
Set fso = CreateObject(“Scripting.FileSystemObject”)
Dim oFile As Object
Set oFile = fso.CreateTextFile(“<Pathname/filename.txt>”)
Set fso = Nothing
Set oFile = Nothing

End Function


Send an Email (bypass Outlook security message)

Option Compare Database

‘This is the procedure that calls the exposed Outlook VBA function…
Public Function FnSendEmail(strTo As String, _
strSubject As String, _
strEmailBody As String, _
strBodyFormat As String, _
Optional strCC As String, _
Optional strAttachments As String) As Boolean

Dim objOutlook As Object ‘ Note: Must be late-binding.
Dim objNameSpace As Object
Dim objExplorer As Object
Dim blnSuccessful As Boolean
Dim blnNewInstance As Boolean

‘Is an instance of Outlook already open that we can bind to?
On Error Resume Next
Set objOutlook = GetObject(, “Outlook.Application”)
On Error GoTo 0

If objOutlook Is Nothing Then

‘Outlook isn’t already running – create a new instance…
Set objOutlook = CreateObject(“Outlook.Application”)
blnNewInstance = True

‘We need to instantiate the Visual Basic environment… (messy)
Set objNameSpace = objOutlook.GetNamespace(“MAPI”)
Set objExplorer = objOutlook.Explorers.Add(objNameSpace.Folders(1), 0)
objExplorer.CommandBars.FindControl(, 1695).Execute
objExplorer.Close
Set objNameSpace = Nothing
Set objExplorer = Nothing

End If

blnSuccessful = objOutlook.FnSendMailSafe(strTo, strSubject, strEmailBody, strBodyFormat, strCC, strAttachments)

If blnNewInstance = True Then objOutlook.Quit
Set objOutlook = Nothing

FnSendEmail = blnSuccessful

End Function


Outlook module to send email (used with code above)

Option Explicit

‘ Code: Send E-mail without Security Warnings
‘ OUTLOOK 2003 VBA CODE FOR ‘ThisOutlookSession’ MODULE
‘ (c) 2005 Wayne Phillips (http://www.everythingaccess.com)
‘ Written 07/05/2005
‘ Updated v1.3 – 11/11/2005

‘ Please read the full tutorial here:
‘ http://www.everythingaccess.com/tutorials.asp?ID=Outlook-Send-E-mail-without-Security-Warning

‘ Please leave the copyright notices in place – Thank you.

Private Sub Application_Startup()

‘IGNORE – This forces the VBA project to open and be accessible using automation
‘         at any point after startup

End Sub

‘ FnSendMailSafe
‘ ————–
‘ Simply sends an e-mail using Outlook/Simple MAPI.
‘ Calling this function by Automation will prevent the warnings
‘ ‘A program is trying to send a mesage on your behalf…’
‘ Also features optional HTML message body and attachments by file path.

‘ The To/CC/BCC/Attachments function parameters can contain multiple items by seperating
‘ them by a semicolon. (e.g. for the strTo parameter, ‘test@test.com; test2@test.com’ is
‘ acceptable for sending to multiple recipients.

‘ Read more here:
‘ http://www.everythingaccess.com/tutorials.asp?ID=Outlook-Send-E-mail-without-Security-Warning

Public Function FnSendMailSafe(strTo As String, _
strSubject As String, _
strEmailBody As String, _
strBrand As String, _
Optional strAttachments As String) As Boolean

‘ (c) 2005 Wayne Phillips – Written 07/05/2005
‘ http://www.everythingaccess.com

‘ You are free to use this code within your application(s)
‘ as long as the copyright notice and this message remains intact.

On Error GoTo ErrorHandler:

Dim MAPISession As Outlook.NameSpace
Dim MAPIFolder As Outlook.MAPIFolder
Dim MAPIMailItem As Outlook.MailItem
Dim oRecipient As Outlook.Recipient
Dim TempArray() As String
Dim varArrayItem As Variant
Dim blnSuccessful As Boolean
Dim intRecipientCount As Integer

intRecipientCount = 0

‘Get the MAPI NameSpace object
Set MAPISession = Application.Session

If Not MAPISession Is Nothing Then

‘Logon to the MAPI session
MAPISession.Logon , , True, False

‘Create a pointer to the Outbox folder
Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderOutbox)
If Not MAPIFolder Is Nothing Then

‘Create a new mail item in the “Outbox” folder
Set MAPIMailItem = MAPIFolder.Items.Add(olMailItem)
If Not MAPIMailItem Is Nothing Then

With MAPIMailItem

‘Create the recipients TO
TempArray = Split(strTo, “;”)
For Each varArrayItem In TempArray

Set oRecipient = .Recipients.Add(CStr(Trim(varArrayItem)))
oRecipient.Type = olTo

If oRecipient.Resolve = False Then
blnSuccessful = False
GoTo ExitRoutine
End If

Set oRecipient = Nothing

intRecipientCount = intRecipientCount + 1

Next varArrayItem

‘Email Specifics
.ReadReceiptRequested = True
.DeleteAfterSubmit = True
.Subject = strSubject
.Body = strEmailBody

.SentOnBehalfOfName = “email@hotmail.com”

‘Add any specified attachments
TempArray = Split(strAttachments, “;”)
For Each varArrayItem In TempArray

.Attachments.Add CStr(Trim(varArrayItem))

Next varArrayItem

.Send ‘No return value since the message will remain in the outbox if it fails to send
‘.Save

Set MAPIMailItem = Nothing

End With

End If

Set MAPIFolder = Nothing

End If

MAPISession.Logoff

End If

‘If we got to here, then we shall assume everything went ok.
blnSuccessful = True

ExitRoutine:
On Error Resume Next
Set MAPIMailItem = Nothing
Set MAPIFolder = Nothing
MAPISession.Logoff
Set MAPISession = Nothing
FnSendMailSafe = blnSuccessful

Exit Function

ErrorHandler:
MsgBox “An error has occured in the user defined Outlook VBA function FnSendMailSafe()” & vbCrLf & vbCrLf & _
“Error Number: ” & CStr(Err.Number) & vbCrLf & _
“Error Description: ” & Err.Description, vbApplicationModal + vbCritical
Resume ExitRoutine

End Function


SQL Dates

If your program may be used outside of the United States (Britain, Korea, etc.), you need to be aware that many countries use other date formats such as dd/mm/yy, yy/mm/dd. Jet SQL requires dates in American format (mm/dd/yy). Dates entered as criteria in the Query Design grid are correctly interpreted by Access.

When you build SQL strings in VBA, you must explicitly format the dates for Jet. Failure to do so means you code is broken if the user changes the Regional Settings in Control Panel. When you format the date, the Format() function replaces the slashes in the format string with the date separator defined in Control Panel. The slashes in the format string must therefore be preceeded by backslashes to indicate you want literal slash characters.

‘In a general module, create a function that returns a string representing the date as #mm/dd/yyyy#.

Function SQLDate(vDate As Variant) As String
If IsDate(vDate) Then
SQLDate = “#” & Format$(vDate, “mm\/dd\/yyyy”) & “#”
End If
End Function

‘Always wrap dates passed to Jet in this function, e.g.:

Dim strWhere As String
If Not IsNull(Me.StartDate) Then
strWhere = “[InvoiceDate] >= ” & SQLDate(Me.StartDate)
End If
DoCmd.OpenReport “MyReport”, acViewPreview, , strWhere


Download email attachments

Dim olApp As Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olRecipient As Outlook.RECIPIENT
Dim olMAPIFolder As Outlook.MAPIFolder
Dim objItem As Object
Dim olAtmt As Outlook.Attachment
Dim strMailAccount As String
Dim strIdentifier As String ‘for filenames (padded with leading zeros)
Dim lngIdentifier As Long ‘for table values to be stored as a number
Dim strFilename As String
Dim strAttachments As String ‘Keep track of attachments found
Dim strCampaign As String ‘Date Prospect File was originally created (yyyymmdd)
Dim strOrigCreatedDate As String
Dim strSQL As String ‘For insert into table tblResultFiles
Dim lngUnactionedFiles As Long ‘Used to check if any existing files haven’t been imported yet
Dim blnFileExists As Boolean ‘Used to check if a file couldn’t be downloaded because it was already in working directory
Dim i As Long ‘Used to count number of mailbox items
Dim j As Integer ‘Used to count number of attachments savedSet olApp = Outlook.Application
Set olNameSpace = olApp.GetNamespace(“MAPI”)
Set olRecipient = olNameSpace.CreateRecipient(“emailaddress@hotmail.com“)
Set olMAPIFolder = olNameSpace.GetSharedDefaultFolder(olRecipient, olFolderInbox)
gstrWorkingDir = “c:\temp”
‘Ensure that there are items in the Inbox
If olMAPIFolder.Items.Count > 0 Then

For Each objItem In olMAPIFolder.Items

strAttachments = “”
i = i + 1
If objItem.Class = olMail Then ‘Only work with Mail Items
For Each olAtmt In objItem.Attachments
If olAtmt.Type = olByValue Then ‘Attachments that can be saved
If Right(olAtmt.FileName, 4) = “.xls” Then
‘strIdentifier = Mid(objItem.Subject, 8, 8)
strFilename = gstrWorkingDir & “\File” & i & “.xls”
‘If file already exists don’t download again
If Len(Dir(strFilename)) = 0 Then
olAtmt.SaveAsFile strFilename
strAttachments = olAtmt.FileName
j = j + 1 ‘increment number of emails with correct attachment
DoCmd.SetWarnings True
objItem.Subject = objItem.Subject & ” (Attachment Downloaded)”
objItem.Save
Exit For   ‘If we found the correct attachment then delete attachment and look at next email. This will ignore additional attachments (i.e. virus checks, etc)
Else
blnFileExists = True
End If         ‘Len(strFilename)
End If         ‘Subject & Filename
End If         ‘olByValue
Next olAtmt
End If     ‘olMail
Next objItem
Else
End If


To view the page on Regular Expressions click here.