├── Modules ├── Dates.bas ├── SanitizeInput.bas ├── Email.bas ├── GenericFunctions.bas ├── ListBuilder.bas ├── Properties.bas ├── Strings.bas ├── Distribution.bas ├── VersionControl.bas ├── Reference.bas ├── DomainFunctionWrappers.bas ├── CommonExcelFunctions.bas ├── DatabaseUtilities.bas └── Files.bas ├── Classes ├── ExcelHandler.cls ├── CodeProfiler.cls ├── RecordsetWrapper.cls ├── Timer.cls ├── ActionLogger.cls └── ErrorLogger.cls ├── Logging ├── Logger.bas ├── Timer.cls └── LogEvent.cls ├── Table Schemas ├── Properties.xsd └── Properties.xml └── Interfaces └── IContainer.cls /Modules/Dates.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Dates" 2 | Option Explicit 3 | 4 | Public Function DaysInMonth(TargetDate As Date) As Integer 5 | DaysInMonth = Day(DateAdd("d", -1, DateSerial(Year(TargetDate), Month(TargetDate) + 1, 1))) 6 | End Function 7 | 8 | Public Function IsLeapYear(Year As Integer) As Boolean 9 | IsLeapYear = (Month(DateSerial(Year, 2, 29)) = 2) 10 | End Function 11 | -------------------------------------------------------------------------------- /Classes/ExcelHandler.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "ExcelHandler" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Compare Database 11 | Option Explicit 12 | 13 | Private this As ExcelHandlerFields 14 | Private Type ExcelHandlerFields 15 | Application As Excel.Application 16 | End Type 17 | 18 | Private Property Let ExcelApp(e As Excel.Application) 19 | Set this.Application = e 20 | End Property 21 | Property Get ExcelApp() As Excel.Application 22 | Set ExcelApp = this.Application 23 | End Property 24 | 25 | Private Sub Class_Initialize() 26 | ExcelApp = New Excel.Application 27 | End Sub 28 | 29 | Function OpenWorkbook(WorkbookPath As String) As Excel.Workbook 30 | Set OpenWorkbook = ExcelApp.Workbooks.Open(WorkbookPath, False) 31 | End Function 32 | 33 | Private Sub Class_Terminate() 34 | 35 | Dim wb As Workbook 36 | For Each wb In ExcelApp.Workbooks 37 | wb.Saved = True 38 | wb.Close False 39 | Next wb 40 | 41 | On Error Resume Next 42 | ExcelApp.Quit 43 | ExcelApp = Nothing 44 | On Error GoTo 0 45 | 46 | End Sub 47 | -------------------------------------------------------------------------------- /Modules/SanitizeInput.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "SanitizeInput" 2 | Option Compare Database 3 | Option Explicit 4 | 5 | Private Const DATE_FORMAT = "YYYY-MM-DD HH:NN:SS" 6 | 7 | Public Function Sanitize(ByVal InputData As Variant) As String 8 | 9 | If IsDate(InputData) Then 10 | Sanitize = SanitizeDate(CDate(InputData)) 11 | Else 12 | Sanitize = SanitizeString(CStr(InputData)) 13 | End If 14 | 15 | End Function 16 | 17 | Private Function SanitizeString(ByVal InputString As String) As String 18 | 19 | If Not StringIsClean(InputString) Then 20 | 21 | If InStr(2, InputString, "'") > 0 Then 22 | InputString = """" & InputString & """" 23 | Else 24 | InputString = "'" & InputString & "'" 25 | End If 26 | 27 | End If 28 | 29 | SanitizeString = InputString 30 | 31 | End Function 32 | 33 | Private Function SanitizeDate(InputDate As Date) As String 34 | SanitizeDate = "'" & Format(InputDate, DATE_FORMAT) & "'" 35 | End Function 36 | 37 | Private Function StringIsClean(InputString As String) As Boolean 38 | 39 | StringIsClean = _ 40 | (Left(InputString, 1) = "'" And Right(InputString, 1) = "'") _ 41 | Or (Left(InputString, 1) = """" And Right(InputString, 1) = """") 42 | 43 | End Function 44 | -------------------------------------------------------------------------------- /Modules/Email.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Email" 2 | Option Explicit 3 | Option Compare Database 4 | 5 | Public Sub SendMail(EmailAddress As String, SubjectLine As String, BodyText As String, SenderName As String) 6 | 7 | With New CDO.Message 8 | Set .Configuration = CreateConfiguration 9 | .To = EmailAddress 10 | .CC = vbNullString 11 | .BCC = vbNullString 12 | .FROM = SenderEmailAddress(SenderName) 13 | .Subject = SubjectLine 14 | .TextBody = BodyText 15 | .Send 16 | End With 17 | 18 | End Sub 19 | 20 | Private Function SenderEmailAddress(Sender As String) As String 21 | SenderEmailAddress = """" & Sender & """ " 22 | End Function 23 | 24 | Private Function CreateConfiguration() As CDO.Configuration 25 | 26 | Set CreateConfiguration = New CDO.Configuration 27 | 28 | CreateConfiguration.Load -1 ' CDO Source Defaults 29 | With CreateConfiguration.Fields 30 | .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 31 | .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "wmetech.woodmac.com" 32 | .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 33 | .Update 34 | End With 35 | 36 | End Function 37 | -------------------------------------------------------------------------------- /Modules/GenericFunctions.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "GenericFunctions" 2 | Option Explicit 3 | 4 | Public Function Exists(Collection As Object, Key As String) As Boolean 5 | 6 | 'Collection is declared as an Object to allow iteration over 7 | 'DAO Properties collections/TableDefs etc. as well as VBA Collection objects 8 | 9 | On Error GoTo DoesNotExist 10 | Dim s As String 11 | s = TypeName(Collection(Key)) 12 | Exists = True 13 | 14 | Exit Function 15 | 16 | DoesNotExist: 17 | Exists = False 18 | 19 | End Function 20 | 21 | 22 | Public Function IsArrayInitialized(ArrayToCheck As Variant) As Boolean 23 | 24 | On Error GoTo IsArrayInitialized_Exit 25 | 26 | If UBound(ArrayToCheck) > -1 Then 27 | IsArrayInitialized = True 28 | End If 29 | 30 | Exit Function 31 | 32 | IsArrayInitialized_Exit: 33 | IsArrayInitialized = False 34 | 35 | End Function 36 | 37 | 38 | Public Function AddToStringList(List As String, NewItem As String) As String 39 | 40 | If Len(List) > 0 Then 41 | AddToStringList = List & "," & Sanitize(NewItem) 42 | Else 43 | AddToStringList = List & Sanitize(NewItem) 44 | End If 45 | 46 | End Function 47 | 48 | Public Function AddToNumberList(List As String, NewItem As Variant) As String 49 | 50 | If Len(List) > 0 Then 51 | AddToNumberList = List & "," & CStr(NewItem) 52 | Else 53 | AddToNumberList = List & CStr(NewItem) 54 | End If 55 | 56 | End Function 57 | 58 | Public Sub EnableXPath(XMLDoc As DOMDocument) 59 | XMLDoc.SetProperty "SelectionLanguage", "XPath" 60 | End Sub 61 | -------------------------------------------------------------------------------- /Modules/ListBuilder.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "ListBuilder" 2 | Option Compare Database 3 | Option Explicit 4 | 5 | Public Enum SelectionStatus 6 | Selected 7 | AllItems 8 | End Enum 9 | 10 | Public Function GetList(ListBox As ListBox, Column As Long, ItemSelection As SelectionStatus) As String 11 | 12 | Select Case ItemSelection 13 | Case Is = SelectionStatus.AllItems 14 | GetList = GetAllItems(ListBox, Column) 15 | Case Is = SelectionStatus.Selected 16 | GetList = GetSelectedItems(ListBox, Column) 17 | End Select 18 | 19 | End Function 20 | 21 | Private Function GetSelectedItems(ListBox As ListBox, Column As Long) As String 22 | Dim SelectedItem As Variant 23 | For Each SelectedItem In ListBox.ItemsSelected 24 | If Not IsNull(ListBox.Column(Column, SelectedItem)) Then 25 | GetSelectedItems = AddToNumberList(GetSelectedItems, ListBox.Column(Column, SelectedItem)) 26 | End If 27 | Next SelectedItem 28 | End Function 29 | 30 | Private Function GetAllItems(ListBox As ListBox, Column As Long) As String 31 | Dim ListItem As Long 32 | For ListItem = 0 To ListBox.ListCount - 1 33 | If Not IsNull(ListBox.Column(Column, ListItem)) Then 34 | GetAllItems = AddToNumberList(GetAllItems, ListBox.Column(Column, ListItem)) 35 | End If 36 | Next ListItem 37 | End Function 38 | 39 | 40 | Private Function AddToNumberList(List As String, NewItem As Variant) As String 41 | 42 | If Len(List) > 0 Then 43 | AddToNumberList = List & "," & CStr(NewItem) 44 | Else 45 | AddToNumberList = List & CStr(NewItem) 46 | End If 47 | 48 | End Function 49 | -------------------------------------------------------------------------------- /Classes/CodeProfiler.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "CodeProfiler" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Explicit 11 | 12 | 'These API functions count extremely high-resolution processing rates (i.e. CPU cycles) 13 | 'QueryPerformanceCounter counts CPU cycles, and QueryPerformanceFrequency gives the number of cycles per second 14 | 'Thus we can work out extremely accurate run-times for processes. 15 | 16 | 'Currency is used as it is essentially a structured data type with integer & decimal parts 17 | Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean 18 | Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean 19 | 20 | Private StartCounter As Currency 21 | Private EndCounter As Currency 22 | 23 | 24 | Private Function Overhead() As Currency 25 | 26 | 'This calculates the CPU overhead of actually running the performance counter 27 | 28 | Static OverheadCounter As Currency 29 | If OverheadCounter = 0 Then 30 | Dim c1 As Currency, c2 As Currency 31 | QueryPerformanceCounter c1 32 | QueryPerformanceCounter c2 33 | OverheadCounter = c2 - c1 34 | Else 35 | Overhead = OverheadCounter 36 | End If 37 | 38 | End Function 39 | 40 | Private Function Frequency() As Currency 41 | QueryPerformanceFrequency Frequency 42 | End Function 43 | 44 | Sub StartProfiling() 45 | QueryPerformanceCounter StartCounter 46 | End Sub 47 | Function GetRunTime() As Double 48 | QueryPerformanceCounter EndCounter 49 | GetRunTime = (EndCounter - StartCounter - Overhead) / Frequency 50 | End Function 51 | -------------------------------------------------------------------------------- /Logging/Logger.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Logger" 2 | Option Compare Database 3 | Option Explicit 4 | 5 | Private Path As String 6 | Private LogEvents As New Collection 7 | Dim fso As New FileSystemObject 8 | 9 | Public Property Let LogFilePath(ByVal s As String) 10 | Path = s 11 | If Len(Dir(s)) = 0 Then 12 | fso.CreateTextFile s 13 | End If 14 | End Property 15 | Private Property Get LogFilePath() As String 16 | LogFilePath = Path 17 | End Property 18 | 19 | Public Sub Log(ByVal EventName As String, Severity As LogSeverity) 20 | LogEvents.Add CreateLogEvent(EventName, Severity), EventName 21 | WriteLog EventName 22 | End Sub 23 | Public Sub CloseLogEvent(ByVal EventName As String, Optional RecordsAffected As Long) 24 | If Not IsMissing(RecordsAffected) Then 25 | LogEvents(EventName).RecordsAffected = RecordsAffected 26 | End If 27 | WriteLog EventName, True 28 | LogEvents.Remove EventName 29 | End Sub 30 | 31 | Private Function CreateLogEvent(ByVal EventName As String, Severity As LogSeverity) As LogEvent 32 | Set CreateLogEvent = New LogEvent 33 | CreateLogEvent.Name = EventName 34 | CreateLogEvent.Severity = Severity 35 | End Function 36 | 37 | Private Sub WriteLog(ByVal EventName As String, Optional CloseEvent As Boolean = False) 38 | Dim LogFileStream As scripting.TextStream 39 | Set LogFileStream = fso.GetFile(LogFilePath).OpenAsTextStream(ForAppending) 40 | If CloseEvent Then 41 | LogFileStream.WriteLine LogEvents(EventName).CloseLogLine 42 | Else 43 | LogFileStream.WriteLine LogEvents(EventName).StartLogLine 44 | End If 45 | End Sub 46 | 47 | Public Function GetEventDuration(ByVal EventName As String) As Double 48 | GetEventDuration = LogEvents(EventName).Duration 49 | End Function 50 | -------------------------------------------------------------------------------- /Logging/Timer.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Timer" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Explicit 11 | 12 | 'These API functions count extremely high-resolution processing rates (i.e. CPU cycles) 13 | 'QueryPerformanceCounter counts CPU cycles, and QueryPerformanceFrequency gives the number of cycles per second 14 | 'Thus we can work out extremely accurate run-times for processes. 15 | 16 | 'Currency is used as it is essentially a structured data type with integer & decimal parts 17 | Private Declare Function QueryPerformanceCounter Lib "kernel32" (X As Currency) As Boolean 18 | Private Declare Function QueryPerformanceFrequency Lib "kernel32" (X As Currency) As Boolean 19 | 20 | Private StartCounter As Currency 21 | Private EndCounter As Currency 22 | 23 | 24 | Private Function Overhead() As Currency 25 | 26 | 'This calculates the CPU overhead of actually running the performance counter 27 | 28 | Static OverheadCounter As Currency 29 | If OverheadCounter = 0 Then 30 | Dim c1 As Currency, c2 As Currency 31 | QueryPerformanceCounter c1 32 | QueryPerformanceCounter c2 33 | OverheadCounter = c2 - c1 34 | Else 35 | Overhead = OverheadCounter 36 | End If 37 | 38 | End Function 39 | 40 | Private Function Frequency() As Currency 41 | QueryPerformanceFrequency Frequency 42 | End Function 43 | 44 | Public Sub Start() 45 | QueryPerformanceCounter StartCounter 46 | End Sub 47 | Public Function GetRunTime() As Double 48 | QueryPerformanceCounter EndCounter 49 | GetRunTime = (EndCounter - StartCounter - Overhead) / Frequency 50 | End Function 51 | 52 | -------------------------------------------------------------------------------- /Table Schemas/Properties.xsd: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | -------------------------------------------------------------------------------- /Interfaces/IContainer.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "IContainer" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | 'Interface for all custom collection classes 11 | 'Classes implementing this interface should contain two Private Collections 12 | 'One for Items, and another for Keys. 13 | 'These should only be accessed using the .Items, .Keys and .Add methods. 14 | 'It is also a good idea to add an IUnknown enumeration in the container class so that .Items 15 | 'becomes the default member, allowing For Each... loops on the Collection class 16 | 17 | 'This class has default member attributes set using a text editor. 18 | 19 | Private this As ContainerFields 20 | Private Type ContainerFields 21 | Items As Collection 22 | Keys As Collection 23 | End Type 24 | 25 | 26 | Private Sub Class_Initialize() 27 | Set this.Items = New Collection 28 | Set this.Keys = New Collection 29 | End Sub 30 | 31 | Public Function NewEnum() As IUnknown 32 | Attribute NewEnum.VB_UserMemId = -4 33 | ' Attribute NewEnum.VB_UserMemId = -4 34 | Set NewEnum = Items.[_NewEnum] 35 | End Function 36 | 37 | 38 | Property Get Items() As Collection 39 | Attribute Items.VB_UserMemId = 0 40 | ' Attribute Items.VB_UserMemId = 0 41 | Set Items = this.Items 42 | End Property 43 | 44 | Property Get Keys() As Collection 45 | Set Keys = this.Keys 46 | End Property 47 | 48 | Sub Add(Item As Variant, Key As Variant) 49 | If Not Exists(Key) Then 50 | Items.Add Item, Key 51 | Keys.Add Key, Key 52 | End If 53 | End Sub 54 | 55 | Sub Remove(Key As Variant) 56 | If Exists(Key) Then 57 | Items.Remove Key 58 | Keys.Remove Key 59 | End If 60 | End Sub 61 | 62 | Function Count() As Long 63 | Count = Items.Count 64 | End Function 65 | 66 | Function Exists(Key As Variant) As Boolean 67 | 68 | On Error GoTo DoesNotExist 69 | 70 | Keys(Key) = Keys(Key) 71 | Exists = True 72 | 73 | Exit Function 74 | 75 | DoesNotExist: 76 | Exists = False 77 | 78 | End Function 79 | 80 | 81 | -------------------------------------------------------------------------------- /Table Schemas/Properties.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 1 5 | Action Log - File Path 6 | LogFilePath 7 | 8 | 9 | 2 10 | Action Log - Reporting Type 11 | LogReportingType 12 | File 13 | 14 | 15 | 3 16 | Error Log - Email Error 17 | ErrorLogEmailError 18 | False 19 | 20 | 21 | 4 22 | Error Log - Email Recipients 23 | ErrorLogEmailRecipients 24 | danny.fraser@woodmac.com 25 | 26 | 27 | 5 28 | Error Log - File Path 29 | ErrorLogFilePath 30 | 31 | 32 | 6 33 | Error Log - Reporting Type 34 | ErrorLogReportingType 35 | File 36 | 37 | 38 | 7 39 | Application Name 40 | Cost Of Supply Calculator 41 | 42 | 43 | 8 44 | Live Path 45 | 46 | 47 | 9 48 | Release Version 49 | 0.1 50 | 51 | 52 | 10 53 | Error Log - Handle Silently 54 | ErrorLogSilent 55 | False 56 | 57 | 58 | 11 59 | Back End Path 60 | BackEndPath 61 | D:\Workspace\Cost Of Supply Calculator\New Version\Cosc_BE.mdb 62 | 63 | 64 | 12 65 | Support Manual Location 66 | SupportManualPath 67 | 68 | 69 | -------------------------------------------------------------------------------- /Modules/Properties.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Properties" 2 | Option Compare Database 3 | Option Explicit 4 | 5 | 'The enum must match the Properties table Id 6 | Public Enum PropertyLookup 7 | [_Invalid] = -1 8 | [_First] = 1 9 | LogFilePath = 1 10 | LogReportingType = 2 11 | ErrorLogEmailError = 3 12 | ErrorLogEmailRecipients = 4 13 | ErrorLogFilePath = 5 14 | ErrorLogReportingType = 6 15 | AppName = 7 16 | LivePath = 8 17 | ReleaseVersion = 9 18 | SilentError = 10 19 | [_Last] = 10 20 | End Enum 21 | 22 | Public Function GetProperty(PropertyId As PropertyLookup) As String 23 | If RegKeyLookup(PropertyId) <> vbNullString Then 24 | GetProperty = Trim(GetSetting(GetApplicationName, "User Settings", RegKeyLookup(PropertyId), vbNullString)) 25 | Else 26 | GetProperty = Trim(CurrentDb.Containers("Databases").Documents("UserDefined").Properties(StringLookup(PropertyId))) 27 | End If 28 | End Function 29 | 30 | Public Sub SetProperty(PropertyId As PropertyLookup, PropertyValue As Variant) 31 | If RegKeyLookup(PropertyId) <> vbNullString Then 32 | SaveSetting GetApplicationName, "User Settings", RegKeyLookup(PropertyId), Trim(CStr(PropertyValue)) 33 | Else 34 | CurrentDb.Containers("Databases").Documents("UserDefined").Properties(StringLookup(PropertyId)) = Trim(PropertyValue) 35 | End If 36 | End Sub 37 | 38 | Public Function StringLookup(PropertyId As PropertyLookup) As String 39 | StringLookup = DLookupStringWrapper("PropertyName", "Properties", "PropertyId = " & PropertyId, vbNullString) 40 | End Function 41 | Public Function RegKeyLookup(PropertyId As PropertyLookup) As String 42 | RegKeyLookup = DLookupStringWrapper("PropertyRegKey", "Properties", "PropertyId = " & PropertyId, vbNullString) 43 | End Function 44 | 45 | Public Function GetApplicationName() As String 46 | GetApplicationName = GetProperty(AppName) 47 | End Function 48 | 49 | 50 | Public Sub SaveAllUserSettings() 51 | 52 | Dim rs As New RecordsetWrapper 53 | rs.OpenRecordset "SELECT PropertyId, PropertyRegKey, DefaultValue FROM Properties" 54 | 55 | Do While Not rs.EOF 56 | 57 | Dim PropertyName As String 58 | PropertyName = Nz(rs!PropertyRegKey, vbNullString) 59 | 60 | Dim PropertyValue As Variant 61 | PropertyValue = Nz(rs!DefaultValue, vbNullString) 62 | 63 | If Len(PropertyName) = 0 Then 64 | 'save locally 65 | If GetProperty(rs!PropertyId) = vbNullString Then 66 | SetProperty rs!PropertyId, PropertyValue 67 | End If 68 | 69 | Else 70 | 'Save to registry 71 | If GetSetting(GetApplicationName, "User Settings", PropertyName) = vbNullString Then 72 | SaveSetting GetApplicationName, "User Settings", PropertyName, PropertyValue 73 | End If 74 | End If 75 | 76 | rs.MoveNext 77 | 78 | Loop 79 | 80 | End Sub 81 | -------------------------------------------------------------------------------- /Logging/LogEvent.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "LogEvent" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Compare Database 11 | Option Explicit 12 | 13 | Private Const LOG_DELIMITER As String = vbTab 14 | 15 | Public Enum LogSeverity 16 | InformationLevel 17 | DetailedLevel 18 | WarningLevel 19 | ErrorLevel 20 | End Enum 21 | 22 | Private Type LogEventFields 23 | Name As String 24 | StartTime As Date 25 | Duration As Double 26 | Severity As LogSeverity 27 | RecordsAffected As Long 28 | RecordsWereAffected As Boolean 29 | EventTimer As Timer 30 | End Type 31 | Private this As LogEventFields 32 | 33 | Private Sub Class_Initialize() 34 | Set this.EventTimer = New Timer 35 | this.EventTimer.Start 36 | this.StartTime = Now 37 | this.RecordsWereAffected = False 38 | End Sub 39 | 40 | Public Property Let Name(n As String) 41 | this.Name = n 42 | End Property 43 | Private Property Get Name() As String 44 | Name = this.Name 45 | End Property 46 | 47 | Private Property Get StartTime() As Date 48 | StartTime = this.StartTime 49 | End Property 50 | 51 | Public Property Get Duration() As Double 52 | Duration = Round(this.EventTimer.GetRunTime, 3) 53 | End Property 54 | 55 | Public Property Let Severity(s As LogSeverity) 56 | this.Severity = s 57 | End Property 58 | Public Property Get Severity() As LogSeverity 59 | Severity = this.Severity 60 | End Property 61 | 62 | Public Property Let RecordsAffected(r As Long) 63 | this.RecordsAffected = r 64 | this.RecordsWereAffected = True 65 | End Property 66 | Private Property Get RecordsAffected() As Long 67 | RecordsAffected = this.RecordsAffected 68 | End Property 69 | 70 | Private Property Get RecordsWereAffected() As Boolean 71 | RecordsWereAffected = this.RecordsWereAffected 72 | End Property 73 | 74 | Public Function CloseLogLine() As String 75 | CloseLogLine = _ 76 | Join( _ 77 | Array(SeverityLabel, StartTime, "END " & Name, Duration, IIf(RecordsAffected, RecordsAffected, vbNullString)), _ 78 | LOG_DELIMITER) 79 | End Function 80 | 81 | Public Function StartLogLine() 82 | StartLogLine = _ 83 | Join( _ 84 | Array(SeverityLabel, StartTime, Name), _ 85 | LOG_DELIMITER) 86 | End Function 87 | 88 | Private Function SeverityLabel() As String 89 | 90 | Select Case Severity 91 | Case Is = LogSeverity.DetailedLevel 92 | SeverityLabel = "DETAIL" 93 | Case Is = LogSeverity.InformationLevel 94 | SeverityLabel = "INFORMATION" 95 | Case Is = LogSeverity.WarningLevel 96 | SeverityLabel = "WARNING" 97 | Case Is = LogSeverity.ErrorLevel 98 | SeverityLabel = "ERROR" 99 | End Select 100 | 101 | End Function 102 | -------------------------------------------------------------------------------- /Classes/RecordsetWrapper.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "RecordsetWrapper" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Compare Database 11 | Option Explicit 12 | 13 | Private m_rs As DAO.Recordset 14 | 15 | 16 | Public Function GetRecordsetClone(rs As DAO.Recordset) As DAO.Recordset 17 | If Not m_rs Is Nothing Then 18 | Debug.Assert False ' This is only designed to be used once 19 | Else 20 | Set m_rs = rs.Clone 21 | Set GetRecordsetClone = m_rs 22 | End If 23 | End Function 24 | 25 | 26 | Sub OpenRecordset(Domain As String, _ 27 | Optional Criteria As String = vbNullString, _ 28 | Optional OrderBy As String = vbNullString, _ 29 | Optional RecordsetType As DAO.RecordsetTypeEnum = dbOpenDynaset, _ 30 | Optional RecordsetOptions As DAO.RecordsetOptionEnum _ 31 | ) 32 | 33 | 34 | If Not m_rs Is Nothing Then 35 | ' Close the recordset so it can be re-used 36 | CloseRecordset 37 | End If 38 | 39 | Dim SQL As String 40 | SQL = "SELECT * FROM (" & Domain & ")" 41 | 42 | If Criteria <> vbNullString Then 43 | SQL = SQL & " WHERE " & Criteria 44 | End If 45 | 46 | If OrderBy <> "" Then 47 | SQL = SQL & " ORDER BY " & OrderBy 48 | End If 49 | 50 | On Error GoTo ErrorHandler 51 | Set m_rs = CurrentDb.OpenRecordset(SQL, RecordsetType, RecordsetOptions) 52 | 53 | Done: 54 | Exit Sub 55 | ErrorHandler: 56 | ' verify the private Recordset object was not set 57 | Debug.Assert m_rs Is Nothing 58 | 59 | End Sub 60 | 61 | 62 | Sub Delete() 63 | m_rs.Delete 64 | End Sub 65 | 66 | 67 | Sub AddNew() 68 | m_rs.AddNew 69 | End Sub 70 | 71 | 72 | Sub Edit() 73 | m_rs.Edit 74 | End Sub 75 | 76 | 77 | Sub Update() 78 | m_rs.Update 79 | End Sub 80 | 81 | 82 | Sub MoveNext() 83 | m_rs.MoveNext 84 | End Sub 85 | 86 | Sub MovePrevious() 87 | m_rs.MovePrevious 88 | End Sub 89 | 90 | Sub MoveLast() 91 | m_rs.MoveLast 92 | End Sub 93 | 94 | Sub MoveFirst() 95 | m_rs.MoveFirst 96 | End Sub 97 | 98 | Function EOF() As Boolean 99 | EOF = m_rs.EOF 100 | End Function 101 | 102 | Function BOF() As Boolean 103 | BOF = m_rs.BOF 104 | End Function 105 | 106 | Function RecordCount() As Long 107 | RecordCount = m_rs.RecordCount 108 | End Function 109 | 110 | 111 | Sub CloseRecordset() 112 | 113 | m_rs.Close 114 | Set m_rs = Nothing 115 | 116 | End Sub 117 | 118 | 119 | Public Property Get Recordset() As DAO.Recordset 120 | Attribute Recordset.VB_UserMemId = 0 121 | ' Attribute Recordset.VB_UserMemId = 0 122 | Set Recordset = m_rs 123 | End Property 124 | 125 | 126 | Private Sub Class_Terminate() 127 | If Not m_rs Is Nothing Then 128 | m_rs.Close 129 | Set m_rs = Nothing 130 | End If 131 | End Sub 132 | 133 | -------------------------------------------------------------------------------- /Modules/Strings.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Strings" 2 | Option Explicit 3 | 4 | 5 | Public Function Concat(FirstPart As String, SecondPart As String) As String 6 | 7 | 'Concatenates two strings by pre-allocating space. 8 | 'Faster than adding to a string using '&' 9 | 10 | Dim NewLength As Long 11 | NewLength = Len(FirstPart) + Len(SecondPart) 12 | 13 | Concat = Space(NewLength) 14 | 15 | Mid(Concat, 1, Len(FirstPart)) = FirstPart 16 | Mid(Concat, Len(FirstPart) + 1, Len(SecondPart)) = SecondPart 17 | 18 | End Function 19 | 20 | 21 | Public Function RemoveIllegalChars(ByVal Name As String) As String 22 | 23 | 'This will make a valid filename from an otherwise invalid string. 24 | 'The original string remains intact (unless specified outside of this function) as it is passed ByVal 25 | 26 | Dim IllegalChars() As Variant 27 | IllegalChars = Array("<", ">", "|", "/", "*", "\", "?", """", ":") 28 | 29 | Dim Char As Variant 30 | For Each Char In IllegalChars 31 | Name = Replace(Name, Char, vbNullString, 1) 32 | Next Char 33 | 34 | RemoveIllegalChars = Name 35 | 36 | End Function 37 | 38 | 39 | Public Function IsAlphaNumeric(Check As String) As Boolean 40 | 41 | Dim re As RegExp 42 | 43 | Set re = New RegExp 44 | 45 | re.IgnoreCase = True 46 | re.Pattern = "^[A-Z0-9]*$" 47 | 48 | IsAlphaNumeric = re.Test(Check) 49 | 50 | End Function 51 | 52 | 53 | Public Function ReverseString(Text As String) As String 54 | 55 | ReverseString = Space(Len(Text)) 56 | 57 | Dim CharPosition As Integer 58 | For CharPosition = Len(Text) To 1 Step -1 59 | Mid(ReverseString, CharPosition, 1) = Mid(Text, Len(Text) - CharPosition + 1, 1) 60 | Next CharPosition 61 | 62 | End Function 63 | 64 | 65 | Public Function IsValidEmailAddress(Address As String) As Boolean 66 | 67 | With New RegExp 68 | .IgnoreCase = True 69 | .Pattern = "^[A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}$" 70 | IsValidEmailAddress = .Test(Address) 71 | End With 72 | 73 | End Function 74 | 75 | 76 | Public Function AddPathSeparator(Path As String) As String 77 | 78 | If Right$(Path, 1) <> "\" Then 79 | AddPathSeparator = Path & "\" 80 | Else 81 | AddPathSeparator = Path 82 | End If 83 | 84 | End Function 85 | 86 | 87 | Public Function RemovePathSeparator(Path As String) As String 88 | 89 | If Right$(Path, 1) = "\" Then 90 | RemovePathSeparator = Left(Path, Len(Path) - 1) 91 | Else 92 | RemovePathSeparator = Path 93 | End If 94 | 95 | End Function 96 | 97 | 98 | Public Function StripBrackets(Text As String) As String 99 | 100 | If Len(Replace(Text, "(", vbNullString)) <> Len(Replace(Text, ")", vbNullString)) Then 101 | Exit Function 102 | End If 103 | 104 | Dim LastOpenBracket As Integer 105 | LastOpenBracket = InStrRev(Text, "(") 106 | 107 | If LastOpenBracket <> 0 Then 108 | 109 | Dim NextCloseBracket As Integer 110 | NextCloseBracket = InStr(LastOpenBracket, Text, ")") 111 | 112 | If NextCloseBracket = 0 Then 113 | Exit Function 114 | End If 115 | 116 | Dim StrippedText As String 117 | StrippedText = RTrim(Left(Text, LastOpenBracket - 1)) & Right(Text, Len(Text) - NextCloseBracket) 118 | 119 | StripBrackets = StripBrackets(StrippedText) 120 | 121 | Else 122 | 123 | StripBrackets = Text 124 | 125 | End If 126 | 127 | End Function 128 | 129 | Public Function RemoveDoubleSpaces(ByVal StringToAmend As String) As String 130 | 131 | Do While InStr(1, StringToAmend, " ") > 0 132 | StringToAmend = Replace(StringToAmend, " ", " ") 133 | Loop 134 | 135 | RemoveDoubleSpaces = StringToAmend 136 | 137 | End Function 138 | -------------------------------------------------------------------------------- /Modules/Distribution.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Distribution" 2 | Option Compare Database 3 | Option Explicit 4 | 5 | Public Function AutoExec_Startup() 6 | 7 | SetDevelopmentOptions 8 | 9 | Properties.SaveAllUserSettings 10 | 11 | If UpdateAvailable And Not (OpenedViaCitrix) Then 12 | MsgBox "NEW VERSION AVAILABLE AT:" & vbNewLine & GetProperty(LivePath) 13 | SelectFile GetProperty(LivePath) 14 | DoCmd.Quit acQuitSaveNone 15 | End If 16 | 17 | End Function 18 | 19 | Public Sub SetDevelopmentOptions() 20 | 21 | If IsCompiled Then 22 | PrepareForDistribution 23 | Else 24 | PrepareForDevelopment 25 | End If 26 | 27 | End Sub 28 | 29 | 30 | Private Sub PrepareForDistribution() 31 | 32 | Dim ToolBarIndex As Integer 33 | For ToolBarIndex = 1 To CommandBars.Count 34 | CommandBars(ToolBarIndex).Enabled = False 35 | Next ToolBarIndex 36 | 37 | If CDbl(Application.Version) > 11 Then 38 | DoCmd.ShowToolbar "Ribbon", acToolbarNo 39 | End If 40 | 41 | 'Application Properties 42 | ChangeApplicationProperty "StartupShowDBWindow", dbBoolean, False 43 | ChangeApplicationProperty "StartupShowStatusBar", dbBoolean, False 44 | ChangeApplicationProperty "AllowBuiltinToolbars", dbBoolean, False 45 | ChangeApplicationProperty "AllowFullMenus", dbBoolean, False 46 | ChangeApplicationProperty "AllowBreakIntoCode", dbBoolean, False 47 | ChangeApplicationProperty "AllowSpecialKeys", dbBoolean, False 48 | ChangeApplicationProperty "AllowBypassKey", dbBoolean, False 49 | 50 | DatabaseUtilities.HideDatabaseWindow 51 | 52 | End Sub 53 | 54 | Private Sub PrepareForDevelopment() 55 | 56 | Dim ToolBarIndex As Integer 57 | For ToolBarIndex = 1 To CommandBars.Count 58 | CommandBars(ToolBarIndex).Enabled = True 59 | Next ToolBarIndex 60 | 61 | If CDbl(Application.Version) > 11 Then 62 | DoCmd.ShowToolbar "Ribbon", acToolbarYes 63 | End If 64 | 65 | 'Application Properties 66 | ChangeApplicationProperty "StartupShowDBWindow", dbBoolean, True 67 | ChangeApplicationProperty "StartupShowStatusBar", dbBoolean, True 68 | ChangeApplicationProperty "AllowBuiltinToolbars", dbBoolean, True 69 | ChangeApplicationProperty "AllowFullMenus", dbBoolean, True 70 | ChangeApplicationProperty "AllowBreakIntoCode", dbBoolean, True 71 | ChangeApplicationProperty "AllowSpecialKeys", dbBoolean, True 72 | ChangeApplicationProperty "AllowBypassKey", dbBoolean, True 73 | 74 | End Sub 75 | 76 | 77 | Public Function IsCompiled() As Boolean 78 | If Exists(CurrentDb.Properties, "MDE") Then 79 | IsCompiled = (CurrentDb.Properties("MDE") = "T") 80 | End If 81 | End Function 82 | 83 | Private Sub ChangeApplicationProperty(PropertyName As String, PropertyType As DAO.DataTypeEnum, PropertyValue As Variant) 84 | 85 | If Exists(CurrentDb.Properties, PropertyName) Then 86 | CurrentDb.Properties(PropertyName) = PropertyValue 87 | Else 88 | Dim NewProperty As DAO.Property 89 | Set NewProperty = CurrentDb.CreateProperty(PropertyName, PropertyType, PropertyValue) 90 | CurrentDb.Properties.Append NewProperty 91 | End If 92 | 93 | End Sub 94 | 95 | 96 | Private Function UpdateAvailable() As Boolean 97 | 98 | UpdateAvailable = False 99 | 100 | If HasProperty(CurrentDb, StringLookup(ReleaseVersion)) And GetProperty(PropertyLookup.LivePath) <> vbNullString Then 101 | 102 | Dim LocalVersion As Double 103 | LocalVersion = GetProperty(ReleaseVersion) 104 | 105 | Dim LiveVersion As Double 106 | LiveVersion = GetLiveVersion(GetProperty(PropertyLookup.LivePath)) 107 | 108 | If LiveVersion > LocalVersion Then 109 | UpdateAvailable = True 110 | End If 111 | 112 | End If 113 | 114 | End Function 115 | 116 | Private Function GetLiveVersion(LivePath As String) As Double 117 | 118 | If Files.FileExists(LivePath) Then 119 | GetLiveVersion = OpenDatabase(LivePath).Containers("Databases").Documents("UserDefined").Properties(StringLookup(ReleaseVersion)) 120 | Else 121 | GetLiveVersion = 0 122 | End If 123 | 124 | End Function 125 | 126 | Public Function IncrementVersion() 127 | SetProperty ReleaseVersion, GetProperty(ReleaseVersion) + 1 128 | End Function 129 | 130 | Public Function OpenedViaCitrix() As Boolean 131 | OpenedViaCitrix = (InStr(Environ("computername"), "CTX") > 0) 132 | End Function 133 | -------------------------------------------------------------------------------- /Modules/VersionControl.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "VersionControl" 2 | Option Explicit 3 | 4 | Public Sub VersionControl() 5 | 6 | SaveCodeModules VBE.ActiveVBProject 7 | SaveTableSchemas 8 | SaveQueries 9 | SaveMacros 10 | 11 | End Sub 12 | 13 | 14 | Private Sub SaveCodeModules(VersionProject As VBProject) 15 | 16 | Dim VBC As VBComponent 17 | For Each VBC In VersionProject.VBComponents 18 | 19 | If VBC.CodeModule.CountOfLines > 0 Then 20 | 21 | Dim ModuleName As String 22 | Dim ModuleType As vbext_ComponentType 23 | 24 | ModuleName = VBC.CodeModule.Name 25 | ModuleType = VBC.Type 26 | 27 | If ModuleName Like "Form_*" Then 28 | Application.SaveAsText _ 29 | acForm, _ 30 | Right(ModuleName, Len(ModuleName) - Len("Form_")), _ 31 | GetOutputFolder(GetSubFolderName(ModuleType)) & ModuleName & ".frm" 32 | Else 33 | VBC.Export _ 34 | GetOutputFolder(GetSubFolderName(ModuleType)) & ModuleName & GetExtension(ModuleType) 35 | End If 36 | 37 | End If 38 | 39 | Next VBC 40 | 41 | End Sub 42 | 43 | 44 | Private Function GetExtension(ModuleType As vbext_ComponentType) As String 45 | 46 | Select Case ModuleType 47 | 48 | Case Is = vbext_ct_StdModule 49 | GetExtension = ".bas" 50 | 51 | Case Is = vbext_ct_ClassModule, vbext_ct_Document 52 | GetExtension = ".cls" 53 | 54 | Case Is = vbext_ct_MSForm 55 | GetExtension = ".frm" 56 | 57 | Case Is = vbext_ct_ActiveXDesigner 58 | GetExtension = ".axd" 59 | 60 | End Select 61 | 62 | End Function 63 | 64 | Private Function GetSubFolderName(ModuleType As vbext_ComponentType) As String 65 | 66 | Select Case ModuleType 67 | 68 | Case Is = vbext_ct_StdModule 69 | GetSubFolderName = "Modules" 70 | 71 | Case Is = vbext_ct_ClassModule 72 | GetSubFolderName = "Class Modules" 73 | 74 | Case Is = vbext_ct_Document, vbext_ct_MSForm 75 | GetSubFolderName = "Forms" 76 | 77 | Case Is = vbext_ct_ActiveXDesigner 78 | GetSubFolderName = "Other" 79 | 80 | End Select 81 | 82 | End Function 83 | 84 | 85 | Private Function VersionPath() As String 86 | 87 | VersionPath = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\")) & "Components\" 88 | 89 | If Not Files.FolderExists(VersionPath) Then 90 | Files.CreateFolder (VersionPath) 91 | End If 92 | 93 | End Function 94 | 95 | Private Function GetOutputFolder(SubFolderName As String) As String 96 | GetOutputFolder = VersionPath & SubFolderName & "\" 97 | If Not Files.FolderExists(GetOutputFolder) Then 98 | Files.CreateFolder GetOutputFolder 99 | End If 100 | End Function 101 | 102 | 103 | Private Sub SaveTableSchemas() 104 | 105 | Dim OutputPath As String 106 | OutputPath = GetOutputFolder("Table Schemas") 107 | 108 | Dim t As TableDef 109 | For Each t In CurrentDb.TableDefs 110 | If Not (t.Name Like "MSys*") Then 111 | 112 | ExportXML _ 113 | objecttype:=acExportTable, _ 114 | DataSource:=t.Name, _ 115 | schematarget:=OutputPath & t.Name & ".xsd" 116 | 117 | End If 118 | Next t 119 | 120 | End Sub 121 | 122 | Private Sub SaveQueries() 123 | 124 | Dim OutputPath As String 125 | OutputPath = GetOutputFolder("Queries") 126 | 127 | Dim q As QueryDef 128 | For Each q In CurrentDb.QueryDefs 129 | 130 | If Left(q.Name, 1) <> "~" Then 131 | Files.CreateTextFile OutputPath & q.Name & ".qry", q.SQL 132 | End If 133 | 134 | Next q 135 | 136 | End Sub 137 | 138 | Private Sub SaveMacros() 139 | 140 | Dim OutputPath As String 141 | OutputPath = GetOutputFolder("Macros") 142 | 143 | Dim DB As Database 144 | Set DB = CurrentDb 145 | 146 | Dim Macro As DAO.Document 147 | For Each Macro In DB.Containers("Scripts").Documents 148 | 149 | SaveAsText _ 150 | objecttype:=acMacro, _ 151 | objectname:=Macro.Name, _ 152 | Filename:=OutputPath & Macro.Name & ".mcr" 153 | 154 | Next Macro 155 | 156 | End Sub 157 | 158 | -------------------------------------------------------------------------------- /Modules/Reference.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Reference" 2 | Option Explicit 3 | 4 | Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _ 5 | "RegOpenKeyExA" (ByVal Key As Long, ByVal SubKey As String, _ 6 | ByVal Options As Long, ByVal Desired As Long, Result As Long) _ 7 | As Long 8 | 9 | Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _ 10 | "RegQueryValueExA" (ByVal Key As Long, ByVal ValueName As String, _ 11 | ByVal Reserved As Long, RegType As Long, _ 12 | ByVal Path As String, Data As Long) As Long 13 | 14 | Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal Key As Long) As Long 15 | 16 | Private Const REG_SZ As Long = 1 17 | Private Const KEY_ALL_ACCESS = &H3F 18 | Private Const HKEY_LOCAL_MACHINE = &H80000002 19 | 20 | Public Sub ListReferences() 21 | 22 | 'Adapted from "www.ozgrid.com/forum/showthread.php?t=22483" 23 | 24 | Dim VBProj As VBIDE.VBProject 25 | Set VBProj = VBE.ActiveVBProject 26 | 27 | Dim Reference As VBIDE.Reference 28 | For Each Reference In VBProj.References 29 | With Reference 30 | Debug.Print .Name 31 | Debug.Print .Description 32 | Debug.Print .GUID 33 | Debug.Print .Major 34 | Debug.Print .Minor 35 | Debug.Print .FullPath 36 | Debug.Print vbNullString 37 | End With 38 | Next 39 | 40 | End Sub 41 | 42 | Public Sub AddReferenceFromGuid(GUID As String, Major As Long, Minor As Long) 43 | 44 | 'Adapted from "www.ozgrid.com/forum/showthread.php?t=22483" 45 | 46 | On Error GoTo ExitSub 47 | 48 | VBE.ActiveVBProject.References.AddFromGuid GUID, Major, Minor 49 | 50 | ExitSub: 51 | End Sub 52 | 53 | Public Sub AddReferenceFromFile(FilePath As String) 54 | 55 | 'Adapted from "www.ozgrid.com/forum/showthread.php?t=22483" 56 | 57 | On Error GoTo ExitSub 58 | 59 | VBE.ActiveVBProject.References.AddFromFile FilePath 60 | 61 | ExitSub: 62 | End Sub 63 | 64 | Public Sub RemoveReference(ReferenceName As String) 65 | 66 | 'Adapted from "www.ozgrid.com/forum/showthread.php?t=22483" 67 | 68 | On Error GoTo ExitSub 69 | 70 | Dim Reference As VBIDE.Reference 71 | For Each Reference In VBE.ActiveVBProject.References 72 | If Reference.Name = ReferenceName Then 73 | References.Remove Reference 74 | End If 75 | Next 76 | 77 | ExitSub: 78 | End Sub 79 | 80 | Public Sub InstallExcelReference() 81 | 82 | Dim bolReferenceFound As Boolean 83 | bolReferenceFound = False 84 | 85 | Dim objReference As VBIDE.Reference 86 | For Each objReference In VBE.ActiveVBProject.References 87 | If objReference.Name = "Excel" Then 88 | bolReferenceFound = True 89 | Exit Sub 90 | End If 91 | Next 92 | 93 | If Not bolReferenceFound Then 94 | VBE.ActiveVBProject.References.AddFromFile GetExcelInstallPath 95 | End If 96 | 97 | End Sub 98 | 99 | 100 | Public Sub PrintAllEnvirons() 101 | 102 | Dim i As Integer 103 | i = 1 104 | Do While Environ(i) <> vbNullString 105 | Debug.Print Environ(i) 106 | i = i + 1 107 | Loop 108 | 109 | End Sub 110 | 111 | 112 | Private Function GetExcelInstallPath() As String 113 | 114 | Dim Key As Long 115 | Dim RetVal As Long 116 | Dim CLSID As String 117 | Dim Path As String 118 | Dim n As Long 119 | 120 | 'First, get the clsid from the progid from the registry key: 121 | 'HKEY_LOCAL_MACHINE\Software\Classes\\CLSID 122 | RetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "Software\Classes\Excel.Application\CLSID", 0&, KEY_ALL_ACCESS, Key) 123 | If RetVal = 0 Then 124 | RetVal = RegQueryValueEx(Key, "", 0&, REG_SZ, "", n) 125 | CLSID = Space(n) 126 | RetVal = RegQueryValueEx(Key, "", 0&, REG_SZ, CLSID, n) 127 | CLSID = Left(CLSID, n - 1) 'drop null-terminator 128 | RegCloseKey Key 129 | End If 130 | 131 | 'Now that we have the CLSID, locate the server path at 132 | 'HKEY_LOCAL_MACHINE\Software\Classes\CLSID\{xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxx}\LocalServer32 133 | 134 | RetVal = RegOpenKeyEx(HKEY_LOCAL_MACHINE, "Software\Classes\CLSID\" & CLSID & "\LocalServer32", 0&, KEY_ALL_ACCESS, Key) 135 | If RetVal = 0 Then 136 | 137 | RetVal = RegQueryValueEx(Key, "", 0&, REG_SZ, "", n) 138 | Path = Space(n) 139 | 140 | RetVal = RegQueryValueEx(Key, "", 0&, REG_SZ, Path, n) 141 | Path = Left(Path, n - 1) 142 | RegCloseKey Key 143 | 144 | End If 145 | 146 | GetExcelInstallPath = Trim(Left(Path, InStr(Path, "/") - 1)) 147 | 148 | End Function 149 | 150 | -------------------------------------------------------------------------------- /Modules/DomainFunctionWrappers.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "DomainFunctionWrappers" 2 | Option Compare Database 3 | Option Explicit 4 | 5 | Private Enum DomainFunctionWrapperEnum 6 | DLookup_Wrapper 7 | DCount_Wrapper 8 | DSum_Wrapper 9 | DMax_Wrapper 10 | DMin_Wrapper 11 | DAvg_Wrapper 12 | End Enum 13 | 14 | Private Function DomainFunctionWrapper(DomainFunction As DomainFunctionWrapperEnum, _ 15 | Expr As String, _ 16 | Domain As String, _ 17 | Optional Criteria As String) As Variant 18 | On Error GoTo ErrorHandler 19 | 20 | Select Case DomainFunction 21 | Case DLookup_Wrapper 22 | DomainFunctionWrapper = DLookup(Expr, Domain, Criteria) 23 | Case DCount_Wrapper 24 | DomainFunctionWrapper = DCount(Expr, Domain, Criteria) 25 | Case DSum_Wrapper 26 | DomainFunctionWrapper = DSum(Expr, Domain, Criteria) 27 | Case DMax_Wrapper 28 | DomainFunctionWrapper = DMax(Expr, Domain, Criteria) 29 | Case DMin_Wrapper 30 | DomainFunctionWrapper = DMin(Expr, Domain, Criteria) 31 | Case DSum_Wrapper 32 | DomainFunctionWrapper = DSum(Expr, Domain, Criteria) 33 | Case DAvg_Wrapper 34 | DomainFunctionWrapper = DAvg(Expr, Domain, Criteria) 35 | Case Else 36 | ' Unexpected DomainFunction argument 37 | Debug.Assert False 38 | End Select 39 | 40 | Done: 41 | Exit Function 42 | 43 | ErrorHandler: 44 | Debug.Print Err.Number & " - " & Err.Description 45 | 46 | End Function 47 | 48 | 49 | '-------------------------------------------------------- 50 | ' DLookupWrapper is just like DLookup only it will trap errors. 51 | '-------------------------------------------------------- 52 | Public Function DLookupWrapper(Expr As String, Domain As String, Optional Criteria As String) As Variant 53 | DLookupWrapper = DomainFunctionWrapper(DLookup_Wrapper, Expr, Domain, Criteria) 54 | End Function 55 | 56 | 57 | '-------------------------------------------------------- 58 | ' DLookupStringWrapper is just like DLookup wrapped in an Nz 59 | ' This will always return a String. 60 | '-------------------------------------------------------- 61 | Public Function DLookupStringWrapper(Expr As String, Domain As String, Optional Criteria As String, Optional ValueIfNull As String = vbNullString) As String 62 | DLookupStringWrapper = Nz(DLookupWrapper(Expr, Domain, Criteria), ValueIfNull) 63 | End Function 64 | 65 | 66 | '-------------------------------------------------------- 67 | ' DLookupNumberWrapper is just like DLookup wrapped in 68 | ' an Nz that defaults to 0. 69 | '-------------------------------------------------------- 70 | Public Function DLookupNumberWrapper(Expr As String, Domain As String, Optional Criteria As String, Optional ValueIfNull = 0) As Variant 71 | DLookupNumberWrapper = Nz(DLookupWrapper(Expr, Domain, Criteria), ValueIfNull) 72 | End Function 73 | 74 | 75 | '-------------------------------------------------------- 76 | ' DCountWrapper is just like DCount only it will trap errors. 77 | '-------------------------------------------------------- 78 | Public Function DCountWrapper(Expr As String, Domain As String, Optional Criteria As String) As Long 79 | DCountWrapper = DomainFunctionWrapper(DCount_Wrapper, Expr, Domain, Criteria) 80 | End Function 81 | 82 | 83 | '-------------------------------------------------------- 84 | ' DMaxWrapper is just like DMax only it will trap errors. 85 | '-------------------------------------------------------- 86 | Public Function DMaxWrapper(Expr As String, Domain As String, Optional Criteria As String) As Long 87 | DMaxWrapper = Nz(DomainFunctionWrapper(DMax_Wrapper, Expr, Domain, Criteria), 0) 88 | End Function 89 | 90 | 91 | '-------------------------------------------------------- 92 | ' DMinWrapper is just like DMin only it will trap errors. 93 | '-------------------------------------------------------- 94 | Public Function DMinWrapper(Expr As String, Domain As String, Optional Criteria As String) As Long 95 | DMinWrapper = DomainFunctionWrapper(DMin_Wrapper, Expr, Domain, Criteria) 96 | End Function 97 | 98 | 99 | '-------------------------------------------------------- 100 | ' DSumWrapper is just like DSum only it will trap errors. 101 | '-------------------------------------------------------- 102 | Public Function DSumWrapper(Expr As String, Domain As String, Optional Criteria As String) As Long 103 | DSumWrapper = DomainFunctionWrapper(DSum_Wrapper, Expr, Domain, Criteria) 104 | End Function 105 | 106 | 107 | '-------------------------------------------------------- 108 | ' DAvgWrapper is just like DAvg only it will trap errors. 109 | '-------------------------------------------------------- 110 | Public Function DAvgWrapper(Expr As String, Domain As String, Optional Criteria As String) As Long 111 | DAvgWrapper = DomainFunctionWrapper(DAvg_Wrapper, Expr, Domain, Criteria) 112 | End Function 113 | 114 | -------------------------------------------------------------------------------- /Classes/Timer.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "Timer" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Compare Database 11 | Option Explicit 12 | 13 | Private Type ExactTime 14 | Year As Integer 15 | Month As Integer 16 | DayOfWeek As Integer 17 | Day As Integer 18 | Hour As Integer 19 | Minute As Integer 20 | Second As Integer 21 | Millisecond As Integer 22 | End Type 23 | 24 | Private Declare Function GetLocalTime Lib "kernel32" () As ExactTime 25 | Private Declare Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long) 26 | 27 | Private this As TimerFields 28 | Private Type TimerFields 29 | StartTime As ExactTime 30 | EndTime As ExactTime 31 | TimeSnap As ExactTime 32 | End Type 33 | 34 | Sub SetStartTime() 35 | this.StartTime = GetLocalTime 36 | End Sub 37 | Sub SetEndTime() 38 | this.EndTime = GetLocalTime 39 | End Sub 40 | Sub SnapTime() 41 | this.TimeSnap = GetLocalTime 42 | End Sub 43 | 44 | 45 | Function ExactTimeAsString() As String 46 | ToString GetLocalTime 47 | End Function 48 | Function StartTimeAsString() As String 49 | ToString this.StartTime 50 | End Function 51 | Function EndTimeAsString() As String 52 | ToString this.EndTime 53 | End Function 54 | Function SnapTimeAsString() As String 55 | ToString this.TimeSnap 56 | End Function 57 | 58 | Private Function ToString(t As ExactTime) As String 59 | 60 | ToString = Format(t.Day, "00") & "/" & _ 61 | Format(t.Month, "00") & "/" & _ 62 | Format(t.Year, "0000") & " " & _ 63 | Format(t.Hour, "00") & ":" & _ 64 | Format(t.Minute, "00") & ":" & _ 65 | Format(t.Second, "00") & "." & _ 66 | Format(t.Millisecond, "000") 67 | 68 | End Function 69 | 70 | 71 | Private Function GetTimeDifference(StartTime As ExactTime, EndTime As ExactTime) As ExactTime 72 | 73 | GetTimeDifference.Year = 0 74 | GetTimeDifference.Month = 0 75 | GetTimeDifference.Day = 0 76 | GetTimeDifference.Hour = 0 77 | GetTimeDifference.Minute = 0 78 | GetTimeDifference.Second = 0 79 | GetTimeDifference.Millisecond = 0 80 | 81 | If EndTime.Millisecond - StartTime.Millisecond < 0 Then 82 | GetTimeDifference.Millisecond = GetTimeDifference.Millisecond + 1000 + EndTime.Millisecond - StartTime.Millisecond 83 | GetTimeDifference.Second = GetTimeDifference.Second - 1 84 | Else 85 | GetTimeDifference.Millisecond = GetTimeDifference.Millisecond + EndTime.Millisecond - StartTime.Millisecond 86 | End If 87 | 88 | If GetTimeDifference.Second + EndTime.Second - StartTime.Second < 0 Then 89 | GetTimeDifference.Second = GetTimeDifference.Second + 60 + EndTime.Second - StartTime.Second 90 | GetTimeDifference.Minute = GetTimeDifference.Minute - 1 91 | Else 92 | GetTimeDifference.Second = GetTimeDifference.Second + EndTime.Second - StartTime.Second 93 | End If 94 | 95 | If GetTimeDifference.Minute + EndTime.Minute - StartTime.Minute < 0 Then 96 | GetTimeDifference.Minute = GetTimeDifference.Minute + 60 + EndTime.Minute - StartTime.Minute 97 | GetTimeDifference.Hour = GetTimeDifference.Hour - 1 98 | Else 99 | GetTimeDifference.Minute = GetTimeDifference.Minute + EndTime.Minute - StartTime.Minute 100 | End If 101 | 102 | If GetTimeDifference.Hour + EndTime.Hour - StartTime.Hour < 0 Then 103 | GetTimeDifference.Hour = GetTimeDifference.Hour + 60 + EndTime.Hour - StartTime.Hour 104 | GetTimeDifference.Day = GetTimeDifference.Day - 1 105 | Else 106 | GetTimeDifference.Hour = GetTimeDifference.Hour + EndTime.Hour - StartTime.Hour 107 | End If 108 | 109 | End Function 110 | 111 | 112 | Function GetTimeDifference_Milliseconds() As Long 113 | 114 | Dim TimeDifference As ExactTime 115 | TimeDifference = GetTimeDifference(this.StartTime, this.EndTime) 116 | 117 | Dim Milliseconds As Long 118 | Milliseconds = 0 119 | Milliseconds = Milliseconds + CLng(TimeDifference.Hour) * 60 * 60 * 1000 120 | Milliseconds = Milliseconds + CLng(TimeDifference.Minute) * 60 * 1000 121 | Milliseconds = Milliseconds + CLng(TimeDifference.Second) * 1000 122 | Milliseconds = Milliseconds + TimeDifference.Millisecond 123 | 124 | GetTimeDifference_Milliseconds = Milliseconds 125 | 126 | End Function 127 | 128 | 129 | Function GetTimeDifference_Seconds() As Long 130 | 131 | Dim TimeDifference As ExactTime 132 | TimeDifference = GetTimeDifference(this.StartTime, this.EndTime) 133 | 134 | Dim Seconds As Long 135 | Seconds = 0 136 | Seconds = Seconds + TimeDifference.Hour * 60 * 60 137 | Seconds = Seconds + TimeDifference.Minute * 60 138 | Seconds = Seconds + TimeDifference.Second 139 | Seconds = Seconds + TimeDifference.Millisecond / 1000 140 | 141 | GetTimeDifference_Seconds = Seconds 142 | 143 | End Function 144 | 145 | 146 | Function GetTimeDifference_Minutes() As Long 147 | 148 | Dim TimeDifference As ExactTime 149 | TimeDifference = GetTimeDifference(this.StartTime, this.EndTime) 150 | 151 | Dim Minutes As Long 152 | Minutes = 0 153 | Minutes = Minutes + TimeDifference.Hour * 60 154 | Minutes = Minutes + TimeDifference.Minute 155 | Minutes = Minutes + TimeDifference.Second / 60 156 | 157 | GetTimeDifference_Minutes = Minutes 158 | 159 | End Function 160 | 161 | 162 | Sub Wait(SecondsToWait As Integer) 163 | 164 | Sleep CLng(SecondsToWait * 1000) 165 | 166 | End Sub 167 | 168 | 169 | Function GetExactTime() As Date 170 | SnapTime 171 | With this.TimeSnap 172 | GetExactTime = DateSerial(.Year, .Month, .Day) + TimeSerial(.Hour, .Minute, .Second) 173 | End With 174 | End Function 175 | 176 | Function GetStartTime() As Date 177 | With this.StartTime 178 | GetStartTime = DateSerial(.Year, .Month, .Day) + TimeSerial(.Hour, .Minute, .Second) 179 | End With 180 | End Function 181 | 182 | Function GetEndTime() As Date 183 | With this.EndTime 184 | GetEndTime = DateSerial(.Year, .Month, .Day) + TimeSerial(.Hour, .Minute, .Second) 185 | End With 186 | End Function 187 | -------------------------------------------------------------------------------- /Classes/ActionLogger.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "ActionLogger" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Compare Database 11 | Option Explicit 12 | 13 | 'Create a new ActionLogger object for each action to be logged (alternatively, create as a global object and reuse) 14 | 15 | Private m_LogType As String 16 | Private m_LogPath As String 17 | Private m_Timer As CodeProfiler 18 | 19 | 20 | Private this As EventDetails 21 | Private Type EventDetails 22 | ActionlogId As Long 23 | Username As String 24 | LogonServer As String 25 | ComputerName As String 26 | ApplicationName As String 27 | ActionName As String 28 | ActionDetail As String 29 | StartTime As Date 30 | EndTime As Date 31 | ElapsedSeconds As Double 32 | RecordCount As Long 33 | End Type 34 | 35 | Private Const ACTION_LOG_TABLE_NAME As String = "ActionLog" 36 | 37 | Property Let LogFilePath(p As String) 38 | m_LogPath = p 39 | End Property 40 | Private Property Get LogFilePath() As String 41 | LogFilePath = m_LogPath 42 | End Property 43 | 44 | Private Property Let LogFileType(t As String) 45 | m_LogType = t 46 | End Property 47 | Private Property Get LogFileType() As String 48 | LogFileType = m_LogType 49 | End Property 50 | 51 | 52 | 53 | Private Sub Class_Initialize() 54 | 55 | LogFileType = GetProperty(LogReportingType) 56 | LogFilePath = GetProperty(PropertyLookup.LogFilePath) 57 | 58 | If LogFileType = "Database" And LogFilePath = vbNullString Then 59 | LogFilePath = CurrentProject.FullName 60 | End If 61 | 62 | Set m_Timer = New CodeProfiler 63 | 64 | End Sub 65 | 66 | Private Sub Class_Terminate() 67 | Set m_Timer = Nothing 68 | End Sub 69 | 70 | Public Sub Setup() 71 | 72 | If m_LogType = "Database" Then 73 | 74 | If Len(m_LogPath) > 0 Then 75 | 76 | If Dir(m_LogPath) = vbNullString Then 77 | CreateDatabase m_LogPath, dbLangGeneral 78 | End If 79 | 80 | If Not (TableExists(ACTION_LOG_TABLE_NAME, m_LogPath)) Then 81 | Me.CreateTable 82 | End If 83 | 84 | End If 85 | 86 | End If 87 | 88 | End Sub 89 | 90 | Private Sub SetEventDetails(Action As String, Optional ActionDetail As String, Optional RecordCount As Long) 91 | 92 | With this 93 | .ActionName = Action 94 | .ActionDetail = ActionDetail 95 | .Username = Environ("username") 96 | .LogonServer = Environ("logonserver") 97 | .ComputerName = Environ("computername") 98 | .ApplicationName = GetApplicationName 99 | If Not IsMissing(RecordCount) Then 100 | .RecordCount = RecordCount 101 | End If 102 | End With 103 | 104 | End Sub 105 | 106 | Sub LogEvent(Action As String, Optional ActionDetail As String, Optional RecordCount As Long) 107 | 108 | this.StartTime = Now() 109 | SetEventDetails Action, ActionDetail, RecordCount 110 | WriteToLog 111 | 112 | End Sub 113 | 114 | 115 | Private Sub WriteToLog() 116 | 117 | Select Case LogFileType 118 | Case "Database" 119 | LogToDatabase 120 | Case "File" 121 | LogToFile 122 | Case Else 123 | 'Do nothing 124 | End Select 125 | 126 | End Sub 127 | 128 | 129 | Sub StartTimedEvent(Action As String, Optional ActionDetail As String) 130 | 131 | m_Timer.StartProfiling 132 | this.StartTime = Now() 133 | SetEventDetails "[START] " & Action, ActionDetail 134 | WriteToLog 135 | 136 | End Sub 137 | 138 | 139 | Sub CloseTimedEvent(Optional RecordCount As Long) 140 | 141 | this.ElapsedSeconds = m_Timer.GetRunTime 142 | this.EndTime = Now 143 | this.RecordCount = RecordCount 144 | this.ActionName = Replace(this.ActionName, "[START]", "[FINISH]") 145 | WriteToLog 146 | 147 | End Sub 148 | 149 | Sub CreateTable() 150 | 151 | If m_LogType = "File" Then Exit Sub 152 | 153 | Dim LogDB As DAO.Database 154 | Set LogDB = OpenDatabase(LogFilePath) 155 | 156 | If Not DatabaseUtilities.TableExists(ACTION_LOG_TABLE_NAME, LogFilePath) Then 157 | 158 | LogDB.Execute _ 159 | " CREATE TABLE " & ACTION_LOG_TABLE_NAME _ 160 | & " (ActionLogId COUNTER (1,1) NOT NULL," _ 161 | & " Action MEMO," _ 162 | & " ActionDetail MEMO," _ 163 | & " TimeStampStart DATE," _ 164 | & " TimeStampEnd DATE," _ 165 | & " ElapsedSeconds DOUBLE," _ 166 | & " RecordCount LONG," _ 167 | & " User TEXT(20)," _ 168 | & " LogOnServer TEXT(25)," _ 169 | & " Computer TEXT(25)," _ 170 | & " Application TEXT(255))", _ 171 | dbFailOnError 172 | 173 | End If 174 | 175 | End Sub 176 | 177 | 178 | Private Sub LogToDatabase() 179 | 180 | Dim LogDB As DAO.Database 181 | Set LogDB = OpenDatabase(LogFilePath) 182 | 183 | Dim NewLogEntry As Boolean 184 | NewLogEntry = (this.ActionlogId = 0) 185 | 186 | Dim ActionLog As DAO.Recordset 187 | Set ActionLog = LogDB.OpenRecordset( _ 188 | "SELECT * FROM " & ACTION_LOG_TABLE_NAME & _ 189 | " WHERE ActionLogID = " & IIf(NewLogEntry, 1, this.ActionlogId), _ 190 | dbOpenDynaset) 191 | 192 | 'Add Action Log Record 193 | If NewLogEntry Then 194 | ActionLog.AddNew 195 | Else 196 | ActionLog.Edit 197 | End If 198 | 199 | 'Add Action Log Data 200 | With this 201 | 202 | ActionLog!Action = .ActionName 203 | ActionLog!ActionDetail = .ActionDetail 204 | ActionLog!TimeStampStart = .StartTime 205 | ActionLog!TimeStampEnd = .EndTime 206 | ActionLog!ElapsedSeconds = .ElapsedSeconds 207 | ActionLog!User = .Username 208 | ActionLog!LogonServer = .LogonServer 209 | ActionLog!Computer = .ComputerName 210 | ActionLog!Application = .ApplicationName 211 | 212 | If Not IsNull(.RecordCount) Then 213 | ActionLog!RecordCount = .RecordCount 214 | End If 215 | 216 | End With 217 | 218 | this.ActionlogId = ActionLog!ActionlogId 219 | ActionLog.Update 220 | 221 | ActionLog.Close 222 | LogDB.Close 223 | 224 | End Sub 225 | 226 | 227 | Private Sub LogToFile() 228 | 229 | Dim f As Integer 230 | f = FreeFile(0) 231 | 232 | Open LogFilePath For Append As #f 233 | 234 | Dim ActionText As String 235 | With this 236 | If Left(this.ActionName, Len("[FINISH]")) = "[FINISH]" Then 237 | ActionText = .EndTime & vbTab 238 | Else 239 | ActionText = .StartTime & vbTab 240 | End If 241 | ActionText = ActionText & .ActionName & vbTab 242 | ActionText = ActionText & .ActionDetail & vbTab 243 | If IsNull(.RecordCount) Then 244 | ActionText = ActionText & vbTab 245 | Else 246 | ActionText = ActionText & .RecordCount & " Records Affected" & vbTab 247 | End If 248 | ActionText = ActionText & .Username & vbTab 249 | ActionText = ActionText & .LogonServer & vbTab 250 | ActionText = ActionText & .ComputerName & vbTab 251 | ActionText = ActionText & .ApplicationName 252 | End With 253 | 254 | Print #f, ActionText 255 | Close #f 256 | 257 | End Sub 258 | -------------------------------------------------------------------------------- /Classes/ErrorLogger.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "ErrorLogger" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = False 10 | Option Explicit 11 | 12 | 'This class does not need to be declared and created - it exists as a predeclared object. 13 | 'It can be instantiated again, but there is little need to do so. 14 | 15 | 'Attribute VB_PredeclaredId = True 16 | 17 | Private m_ErrorLogType As String 18 | Private m_ErrorLogPath As String 19 | Private Const ERROR_LOG_TABLE_NAME As String = "ErrorLog" 20 | 21 | Private this As ErrorDetails 22 | Private Type ErrorDetails 23 | Description As String 24 | Source As String 25 | Time As Date 26 | User As String 27 | Server As String 28 | Computer As String 29 | AppName As String 30 | End Type 31 | 32 | 33 | Property Let LogFilePath(p As String) 34 | m_ErrorLogPath = p 35 | End Property 36 | Property Get LogFilePath() As String 37 | LogFilePath = m_ErrorLogPath 38 | End Property 39 | 40 | Private Property Let LogType(t As String) 41 | m_ErrorLogType = t 42 | End Property 43 | Private Property Get LogType() As String 44 | LogType = m_ErrorLogType 45 | End Property 46 | 47 | Private Sub Class_Initialize() 48 | 49 | LogType = GetProperty(ErrorLogReportingType) 50 | LogFilePath = GetProperty(ErrorLogFilePath) 51 | 52 | If LogType = "Database" And LogFilePath = vbNullString Then 53 | LogFilePath = CurrentProject.FullName 54 | End If 55 | 56 | End Sub 57 | 58 | Private Property Get Silent() As Boolean 59 | Silent = GetProperty(SilentError) 60 | End Property 61 | 62 | 63 | Sub LogError(Number As Long, _ 64 | Description As String, _ 65 | Procedure As String, _ 66 | Optional Form As String = vbNullString) 67 | 68 | On Error GoTo ErrorLog_Error 69 | 70 | 'Get Data 71 | this.Description = Sanitize(Description) 72 | this.Source = CurrentObjectName 73 | this.Time = Now() 74 | this.User = Environ("USERNAME") 75 | this.Server = Environ("LOGONSERVER") 76 | this.Computer = Environ("COMPUTERNAME") 77 | this.AppName = GetProperty(AppName) 78 | 79 | If LogType = "Database" Then 80 | LogErrorToDatabase Number, Procedure, Form 81 | Else 82 | LogErrorToFile Number, Procedure, Form 83 | End If 84 | 85 | 86 | If Not Silent Then 87 | 88 | 'Report Error 89 | Dim MsgBoxMessage As String 90 | MsgBoxMessage = ErrorText(Number, this.Description) 91 | 92 | 'Report in Message Box 93 | If MsgBox(MsgBoxMessage, vbYesNo + vbDefaultButton2, Procedure) = vbYes Then 94 | 95 | Dim MsgBoxMessageFull As String 96 | MsgBoxMessageFull = FullErrorText(MsgBoxMessage, Form, Procedure) 97 | 98 | MsgBox MsgBoxMessageFull, vbOKOnly, Procedure 99 | 100 | End If 101 | 102 | 'Report By Email 103 | If GetProperty(ErrorLogEmailError) Then 104 | 105 | 'Report Errors to me 106 | If Number <> 70 Then 107 | Email.SendMail GetProperty(ErrorLogEmailRecipients), "Error in PPD", MsgBoxMessageFull, "GGM PPD" 108 | End If 109 | 110 | End If 111 | 112 | End If 113 | 114 | ErrorLog_Exit: 115 | 116 | Exit Sub 117 | 118 | ErrorLog_Error: 119 | 120 | MsgBox "Error in error logging procedure. Fatal Error." & vbCrLf & vbCrLf & Err.Description, vbOKOnly, "Error Log Error" 121 | End 122 | Resume ErrorLog_Exit 123 | 124 | End Sub 125 | 126 | Private Sub LogErrorToDatabase(Number As Long, Procedure As String, Form As String) 127 | 'Build SQL 128 | Dim SQL As String 129 | SQL = vbNullString 130 | SQL = SQL & "INSERT INTO " & ERROR_LOG_TABLE_NAME & "(" 131 | SQL = SQL & "ErrNumber, " 132 | SQL = SQL & "ErrDescription, " 133 | SQL = SQL & "CurrentObject, " 134 | SQL = SQL & "Form, " 135 | SQL = SQL & "ErrProcedure, " 136 | SQL = SQL & "ErrTime, " 137 | SQL = SQL & "User, " 138 | SQL = SQL & "LogOn, " 139 | SQL = SQL & "Computer, " 140 | SQL = SQL & "Application) " 141 | SQL = SQL & "SELECT " 142 | SQL = SQL & Sanitize(Number) & ", " 143 | SQL = SQL & Sanitize(this.Description) & ", " 144 | SQL = SQL & Sanitize(this.Source) & ", " 145 | SQL = SQL & Sanitize(Form) & ", " 146 | SQL = SQL & Sanitize(Procedure) & ", " 147 | SQL = SQL & Sanitize(this.Time) & ", " 148 | SQL = SQL & Sanitize(this.User) & ", " 149 | SQL = SQL & Sanitize(this.Server) & ", " 150 | SQL = SQL & Sanitize(this.Computer) & ", " 151 | SQL = SQL & Sanitize(this.AppName) 152 | 153 | 154 | Dim ErrorDB As DAO.Database 155 | Set ErrorDB = OpenDatabase(LogFilePath) 156 | 157 | ErrorDB.Execute SQL, dbFailOnError 158 | ErrorDB.Close 159 | 160 | End Sub 161 | 162 | 163 | Private Sub LogErrorToFile(Number As Long, Procedure As String, Form As String) 164 | 'Log Error (Text File) 165 | Dim Times As New Timer 166 | WriteToErrorLog _ 167 | Times.ExactTimeAsString & vbTab & _ 168 | Number & vbTab & _ 169 | this.Description & vbTab & _ 170 | this.Source & vbTab & _ 171 | Form & vbTab & _ 172 | Procedure & vbTab & _ 173 | this.User & vbTab & _ 174 | this.Server & vbTab & _ 175 | this.Computer & vbTab & _ 176 | this.AppName 177 | End Sub 178 | 179 | Private Function ErrorText(Number As Long, Description As String) As String 180 | ErrorText = _ 181 | "An unexpected error has occurred" & vbCrLf & vbCrLf & _ 182 | "ErrNumber: " & Number & vbCrLf & _ 183 | "ErrDescription: " & Description & vbCrLf & _ 184 | "CurrentObject: " & this.Source & vbCrLf 185 | End Function 186 | 187 | Private Function FullErrorText(MessageStart As String, Form As String, Procedure As String) 188 | 189 | FullErrorText = MessageStart 190 | 191 | FullErrorText = FullErrorText & vbCrLf & "Would you like to see full this?" 192 | 193 | FullErrorText = FullErrorText & "Form: " & Form & vbCrLf & _ 194 | "ErrProcedure: " & Procedure & vbCrLf & _ 195 | "ErrTime: " & this.Time & vbCrLf & _ 196 | "User: " & this.User & vbCrLf & _ 197 | "strLogOn: " & this.Server & vbCrLf & _ 198 | "Computer: " & this.Computer & vbCrLf & _ 199 | "Application: " & this.AppName & vbCrLf 200 | 201 | End Function 202 | 203 | Private Sub WriteToErrorLog(ErrorText As String) 204 | 205 | On Error GoTo WriteToErrorLog_Error 206 | 207 | Dim TextFile As Integer 208 | Dim ActionLogLocation As String 209 | 210 | TextFile = FreeFile() 211 | ActionLogLocation = Strings.AddPathSeparator(CurrentProject.Path) & GetProperty(ErrorLogFilePath) 212 | 213 | If Files.FileExists(ActionLogLocation) Then 214 | Open ActionLogLocation For Append As TextFile 215 | Print #TextFile, ErrorText 216 | Close #TextFile 217 | End If 218 | 219 | WriteToErrorLog_Exit: 220 | 221 | Exit Sub 222 | 223 | WriteToErrorLog_Error: 224 | ErrorLogger.LogError Err.Number, Err.Description, "WriteToErrorLog" 225 | Resume WriteToErrorLog_Exit 226 | 227 | End Sub 228 | 229 | Sub CreateTable() 230 | 231 | If m_ErrorLogType = "File" Then Exit Sub 232 | 233 | If Not DatabaseUtilities.TableExists(ERROR_LOG_TABLE_NAME, LogFilePath) Then 234 | 235 | Dim ErrorDB As DAO.Database 236 | Set ErrorDB = OpenDatabase(LogFilePath) 237 | 238 | ErrorDB.Execute _ 239 | " CREATE TABLE " & ERROR_LOG_TABLE_NAME _ 240 | & " (ErrorId COUNTER(1,1) NOT NULL," _ 241 | & " ErrNumber LONG," _ 242 | & " ErrDescription MEMO," _ 243 | & " CurrentObject TEXT(50)," _ 244 | & " Form TEXT(50)," _ 245 | & " ErrProcedure TEXT(50)," _ 246 | & " ErrTime DATE," _ 247 | & " User TEXT(20)," _ 248 | & " LogOnServer TEXT(25)," _ 249 | & " Computer TEXT(25)," _ 250 | & " Application TEXT(255))", _ 251 | dbFailOnError 252 | 253 | End If 254 | 255 | End Sub 256 | 257 | -------------------------------------------------------------------------------- /Modules/CommonExcelFunctions.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "CommonExcelFunctions" 2 | Option Explicit 3 | 4 | Public Sub SetNumberOfWorksheets(NewWorkbook As Workbook, Optional n As Integer = 3) 5 | 6 | 'This will bring the number of worksheets in a workbook to the number specified. 7 | 'It is best used on creating a new workbook 8 | Quiet NewWorkbook 9 | With NewWorkbook 10 | Do While .Worksheets.Count <> n 11 | If .Worksheets.Count > n Then 12 | .Worksheets(.Worksheets.Count).Delete 13 | ElseIf .Worksheets.Count < n Then 14 | .Worksheets.Add after:=.Worksheets(.Worksheets.Count) 15 | End If 16 | Loop 17 | End With 18 | UnQuiet NewWorkbook 19 | 20 | End Sub 21 | 22 | 23 | Public Function OpenWorkbook(Title As String, Optional Filter As String = "All Files,.*") As Workbook 24 | 'This opens a workbook with the prompt and filter specified in the parameters 25 | 'Use in code to set workbook objects, i.e. 26 | 'Set wbkFoo = OpenWorkbook("Open a file", "Comma Separated Value Files,*.csv") 27 | 28 | Dim Filename As String 29 | 30 | Filename = GetOpenFilename(Filter, , Title) 31 | Set OpenWorkbook = Workbooks.Open(Filename) 32 | 33 | End Function 34 | 35 | 36 | Public Sub DeleteSheet(SheetToDelete As Worksheet) 37 | 38 | 'Deletes a worksheet, suppressing any alerts 39 | 40 | Quiet SheetToDelete.Parent 41 | SheetToDelete.Delete 42 | UnQuiet SheetToDelete.Parent 43 | 44 | End Sub 45 | 46 | 47 | Public Sub CloseAndDelete(WorkbookToClose As Workbook) 48 | 49 | 'This will close and delete a file, if it is open in Excel as a workbook. 50 | 'the file need not be a .xls file - this will work on .csv and .txt files opened in Excel. 51 | 52 | Quiet WorkbookToClose 53 | 54 | Dim Filename As String 55 | Filename = WorkbookToClose.FullName 56 | 57 | WorkbookToClose.Saved = True 58 | UnQuiet WorkbookToClose 59 | WorkbookToClose.Close False 60 | Set WorkbookToClose = Nothing 61 | 62 | Files.DeleteFile Filename 63 | 64 | End Sub 65 | 66 | 67 | Public Function SheetExists(SheetName As String, HoldingWorkbook As Workbook) As Boolean 68 | 69 | 'Returns True if a sheet with sheetName exists in the specified workbook 70 | 71 | On Error GoTo fail 72 | 73 | Dim CheckSheet As Worksheet 74 | Set CheckSheet = HoldingWorkbook.Worksheets(SheetName) 75 | 76 | SheetExists = True 77 | 78 | Exit Function 79 | 80 | fail: 81 | SheetExists = False 82 | 83 | End Function 84 | 85 | 86 | Public Function WorkbookExists(WorkbookName As String) As Boolean 87 | 88 | 'Returns True if a workbook with the name specified is open 89 | 90 | On Error GoTo fail 91 | 92 | Dim Test As Workbook 93 | Set Test = Workbooks(WorkbookName) 94 | 95 | WorkbookExists = True 96 | 97 | Exit Function 98 | 99 | fail: 100 | WorkbookExists = False 101 | 102 | End Function 103 | 104 | 105 | Public Function NamedRangeExists(TargetSheet As Worksheet, RangeName As String) As Boolean 106 | 107 | 'Checks if a specific named range exists in a worksheet 108 | 109 | On Error GoTo fail 110 | 111 | Dim TargetRange As Range 112 | Set TargetRange = TargetSheet.Range(RangeName) 113 | 114 | NamedRangeExists = True 115 | 116 | Exit Function 117 | 118 | fail: 119 | NamedRangeExists = False 120 | 121 | End Function 122 | 123 | 124 | 125 | Public Function GetValue(SearchSheet As Worksheet, Row As Long, HeaderText As String, Optional HeaderRow As Integer = 1, Optional DefaultColumn As Integer = 0) As Variant 126 | 127 | Dim Column As Integer 128 | Column = GetColumn(SearchSheet, HeaderText, HeaderRow, DefaultColumn) 129 | 130 | If Not Column = DefaultColumn Then 131 | GetValue = SearchSheet.Cells(Row, Column) 132 | Else 133 | GetValue = "" 134 | End If 135 | 136 | End Function 137 | 138 | 139 | Public Function GetColumn(SearchSheet As Worksheet, HeaderText As String, Optional HeaderRow As Integer = 1, Optional DefaultValue As Integer = 0) As Integer 140 | 141 | Dim Find As Range 142 | Set Find = SearchSheet.Rows(HeaderRow).Find(what:=HeaderText, LookIn:=xlValues, lookat:=xlWhole) 143 | 144 | If Not Find Is Nothing Then 145 | GetColumn = Find.Column 146 | Else 147 | GetColumn = DefaultValue 148 | End If 149 | 150 | End Function 151 | 152 | 153 | 154 | Public Function IsWorkBookOpen(Filename As String) As Boolean 155 | 156 | 'Pass the full workbook path as the input parameter. 157 | 'Returns True if the workbook is already open 158 | 159 | 160 | On Error GoTo fail 161 | 162 | Dim FileNumber As Long 163 | FileNumber = FreeFile(0) 164 | Open Filename For Input Lock Read As #FileNumber 165 | Close FileNumber 166 | 167 | fail: 168 | 169 | Dim ErrorNumber As Integer 170 | ErrorNumber = Err.Number 171 | 172 | Err.Clear 173 | 174 | Select Case ErrorNumber 175 | Case 0 176 | IsWorkBookOpen = False 177 | Case 70 178 | IsWorkBookOpen = True 179 | Case Else 180 | Err.Raise ErrorNumber 181 | End Select 182 | 183 | End Function 184 | 185 | 186 | 187 | Public Sub QuickSort(ByRef ArrayToSort As Variant, LowBound As Long, HighBound As Long) 188 | 189 | 'sorts an array recursively using the QuickSort algorithm 190 | 'From http://en.allexperts.com/q/Visual-Basic-1048/string-manipulation.htm 191 | 'via http://stackoverflow.com/questions/152319/vba-array-sort-function 192 | 193 | Dim TempLowBound As Long 194 | TempLowBound = LowBound 195 | 196 | Dim TempHighBound As Long 197 | TempHighBound = HighBound 198 | 199 | Dim Pivot As Variant 200 | Pivot = ArrayToSort((LowBound + HighBound) \ 2) 201 | 202 | Do While (TempLowBound <= TempHighBound) 203 | 204 | Do While (ArrayToSort(TempLowBound) < Pivot And TempLowBound < HighBound) 205 | TempLowBound = TempLowBound + 1 206 | Loop 207 | 208 | Do While (Pivot < ArrayToSort(TempHighBound) And TempHighBound > LowBound) 209 | TempHighBound = TempHighBound - 1 210 | Loop 211 | 212 | If (TempLowBound <= TempHighBound) Then 213 | Dim TempSwap As Variant 214 | TempSwap = ArrayToSort(TempLowBound) 215 | ArrayToSort(TempLowBound) = ArrayToSort(TempHighBound) 216 | ArrayToSort(TempHighBound) = TempSwap 217 | TempLowBound = TempLowBound + 1 218 | TempHighBound = TempHighBound - 1 219 | End If 220 | 221 | Loop 222 | 223 | If (LowBound < TempHighBound) Then QuickSort ArrayToSort, LowBound, TempHighBound 224 | If (TempLowBound < HighBound) Then QuickSort ArrayToSort, TempLowBound, HighBound 225 | 226 | End Sub 227 | 228 | 229 | Public Function RangeToStringArray(ByVal TargetRange As Range) As String() 230 | 231 | Dim StringArray() As String 232 | ReDim StringArray(TargetRange.Cells.Count) 233 | 234 | If TargetRange.Rows.Count = 1 Then 235 | 236 | 'Turn a row of cells into an array of column elements 237 | Dim Column As Integer 238 | For Column = LBound(StringArray) To UBound(StringArray) 239 | StringArray(Column) = CStr(TargetRange.Cells(1, Column + 1)) 240 | Next Column 241 | 242 | Else 243 | 244 | 'Turn a column of cells into an array of row elements 245 | Dim Row As Long 246 | For Row = LBound(StringArray) To UBound(StringArray) 247 | StringArray(Row) = CStr(TargetRange.Cells(Row + 1, 1)) 248 | Next Row 249 | 250 | End If 251 | 252 | RangeToStringArray = StringArray 253 | 254 | End Function 255 | 256 | Public Sub Quiet(Workbook As Workbook) 257 | Workbook.Application.ScreenUpdating = False 258 | Workbook.Application.DisplayAlerts = False 259 | End Sub 260 | Public Sub UnQuiet(Workbook As Workbook) 261 | Workbook.Application.ScreenUpdating = True 262 | Workbook.Application.DisplayAlerts = True 263 | End Sub 264 | 265 | Public Sub Unfilter(Worksheet As Worksheet) 266 | Worksheet.Cells.AutoFilter 267 | End Sub 268 | 269 | Public Sub CopyResults(Worksheet As Worksheet, Records As DAO.Recordset) 270 | 271 | Dim f As DAO.Field 272 | For Each f In Records.Fields 273 | Worksheet.Cells(1, f.OrdinalPosition + 1) = f.Name 274 | Next f 275 | 276 | Worksheet.Cells(2, 1).CopyFromRecordset Records 277 | 278 | Worksheet.Columns.AutoFit 279 | 280 | End Sub 281 | -------------------------------------------------------------------------------- /Modules/DatabaseUtilities.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "DatabaseUtilities" 2 | Option Explicit 3 | Option Compare Database 4 | 5 | Private Const DB_TYPE_FORM As Long = -32768 6 | Private Const DB_TYPE_QUERY As Integer = 5 7 | Private Const DB_TYPE_TABLE_LOCAL As Integer = 1 8 | Private Const DB_TYPE_TABLE_LINKED As Integer = 6 9 | 10 | Public Function TableExists(TableName As String, Optional Path As String) As Boolean 11 | 12 | Dim DB As DAO.Database 13 | If Path = vbNullString Then 14 | Set DB = CurrentDb 15 | Else 16 | Set DB = OpenDatabase(Path) 17 | End If 18 | 19 | TableExists = Exists(DB.TableDefs, TableName) 20 | 21 | If Path <> vbNullString Then DB.Close 22 | 23 | End Function 24 | 25 | 26 | Public Function QueryExists(QueryName As String, Optional Path As String) As Boolean 27 | 28 | Dim DB As DAO.Database 29 | If Path = vbNullString Then 30 | Set DB = CurrentDb 31 | Else 32 | Set DB = OpenDatabase(Path) 33 | End If 34 | 35 | QueryExists = Exists(DB.QueryDefs, QueryName) 36 | 37 | If Path <> vbNullString Then DB.Close 38 | 39 | End Function 40 | 41 | 42 | Public Function FormExists(FormName As String, Optional Path As String) As Boolean 43 | 44 | Dim DB As DAO.Database 45 | If Path = vbNullString Then 46 | Set DB = CurrentDb 47 | Else 48 | Set DB = OpenDatabase(Path) 49 | End If 50 | 51 | Dim r As DAO.Recordset 52 | Set r = DB.OpenRecordset("SELECT Name, Type FROM MSysObjects WHERE Type = " & DB_TYPE_FORM & " AND Name = " & Sanitize(FormName)) 53 | 54 | FormExists = Not (r.EOF And r.BOF) 55 | 56 | r.Close 57 | Set r = Nothing 58 | 59 | If Path <> vbNullString Then DB.Close 60 | 61 | End Function 62 | 63 | 64 | Public Function FormIsLoaded(FormName As String) As Boolean 65 | 66 | On Error GoTo FormIsLoaded_Error 67 | 68 | Dim Form As AccessObject 69 | 70 | FormIsLoaded = False 71 | 72 | Set Form = CurrentProject.AllForms(FormName) 73 | If Form.IsLoaded Then 74 | If Form.CurrentView <> acCurViewDesign Then 75 | FormIsLoaded = True 76 | End If 77 | End If 78 | 79 | FormIsLoaded_Exit: 80 | 81 | Exit Function 82 | 83 | FormIsLoaded_Error: 84 | 85 | ErrorLogger.LogError Err.Number, Err.Description, "FormIsLoaded" 86 | Resume FormIsLoaded_Exit 87 | 88 | End Function 89 | 90 | 91 | Public Function ModuleExists(ModuleName As String) As Boolean 92 | ModuleExists = Exists(Application.VBE.ActiveVBProject.VBComponents, ModuleName) 93 | End Function 94 | 95 | 96 | Public Function ControlExists(Form As Form, ControlName As String) As Boolean 97 | ControlExists = Exists(Form.Controls, ControlName) 98 | End Function 99 | 100 | 101 | Public Function GetControl(Form As Form, ControlName As String) As Control 102 | 103 | If ControlExists(Form, ControlName) Then 104 | Set GetControl = Form.Controls(ControlName) 105 | Else 106 | Set GetControl = Nothing 107 | End If 108 | 109 | End Function 110 | 111 | 112 | Public Sub CloseAllForms(Optional Exception As String) 113 | 114 | Dim SQL As String 115 | SQL = "SELECT Name FROM MSysObjects WHERE Type=" & DB_TYPE_FORM & _ 116 | "AND LEFT(Name,3)='frm' AND Name <> '" & Exception & "'" 117 | 118 | Dim AccessObjects As DAO.Recordset 119 | Set AccessObjects = CurrentDb.OpenRecordset(SQL, dbOpenDynaset) 120 | 121 | Do Until AccessObjects.EOF 122 | If CurrentProject.AllForms(AccessObjects!Name).IsLoaded Then 123 | DoCmd.Close acForm, AccessObjects!Name, acSavePrompt 124 | End If 125 | AccessObjects.MoveNext 126 | Loop 127 | 128 | AccessObjects.Close 129 | Set AccessObjects = Nothing 130 | 131 | End Sub 132 | 133 | 134 | Public Sub CloseAllTables(DB As DAO.Database, Optional Exception As String) 135 | 136 | Dim SQL As String 137 | SQL = "SELECT Name FROM MSysObjects WHERE (Type=" & DB_TYPE_TABLE_LOCAL & " OR Type=" & DB_TYPE_TABLE_LINKED & ")" & _ 138 | "AND Name <> '" & Exception & "'" 139 | 140 | Dim AccessObjects As DAO.Recordset 141 | Set AccessObjects = DB.OpenRecordset(SQL, dbOpenDynaset) 142 | 143 | Do Until AccessObjects.EOF 144 | On Error Resume Next 145 | DoCmd.Close acTable, AccessObjects!Name, acSaveNo 146 | AccessObjects.MoveNext 147 | Loop 148 | 149 | AccessObjects.Close 150 | Set AccessObjects = Nothing 151 | 152 | End Sub 153 | 154 | 155 | Public Sub CloseAllQueries(DB As DAO.Database, Optional Exception As String) 156 | 157 | Dim SQL As String 158 | SQL = "SELECT Name FROM MSysObjects WHERE (Type=" & DB_TYPE_QUERY & ")" & _ 159 | "AND Name <> '" & Exception & "'" 160 | 161 | Dim AccessObjects As DAO.Recordset 162 | Set AccessObjects = DB.OpenRecordset(SQL, dbOpenDynaset) 163 | 164 | Do Until AccessObjects.EOF 165 | On Error Resume Next 166 | DoCmd.Close acTable, AccessObjects!Name, acSaveNo 167 | AccessObjects.MoveNext 168 | Loop 169 | 170 | AccessObjects.Close 171 | Set AccessObjects = Nothing 172 | 173 | End Sub 174 | 175 | 176 | Public Sub UpdateStatusBar(Optional Message As String, Optional PercentageDone As Integer) 177 | 178 | If Message = vbNullString Then 179 | 180 | If PercentageDone = 0 Then 181 | SysCmd acSysCmdClearStatus 182 | Else 183 | SysCmd acSysCmdUpdateMeter, PercentageDone 184 | End If 185 | 186 | Else 187 | 188 | If PercentageDone = 0 Then 189 | SysCmd acSysCmdSetStatus, Message 190 | Else 191 | SysCmd acSysCmdInitMeter, Message, 100 192 | SysCmd acSysCmdUpdateMeter, PercentageDone 193 | End If 194 | 195 | End If 196 | 197 | End Sub 198 | 199 | Public Function HasProperty(Target As Object, PropertyName As String) As Boolean 200 | HasProperty = Exists(Target.Properties, PropertyName) 201 | End Function 202 | 203 | 204 | Public Sub CreateLogDatabase(Location As String) 205 | 206 | On Error GoTo CreateAccessFile_Error 207 | 208 | If Location = vbNullString Then 209 | Exit Sub 210 | End If 211 | 212 | 'Set application properties 213 | SetProperty ErrorLogFilePath, Location 214 | SetProperty LogFilePath, Location 215 | 216 | 'Prepare new file 217 | Files.DeleteFile Location 218 | Files.CreateFolder Left(Location, InStrRev(Location, "\")) 219 | 220 | Dim DB As DAO.Database 221 | Set DB = CreateDatabase(Location, dbLangGeneral, dbVersion40) 222 | 223 | 'Create tables in log database 224 | Dim ActionLogger As New ActionLogger 225 | ActionLogger.LogFilePath = Location 226 | ActionLogger.CreateTable 227 | 228 | ErrorLogger.LogFilePath = Location 229 | ErrorLogger.CreateTable 230 | 231 | CreateAccessFile_Exit: 232 | 233 | On Error Resume Next 234 | DB.Close 235 | Exit Sub 236 | 237 | CreateAccessFile_Error: 238 | MsgBox Err.Number, Err.Description, "CreateAccessFile" 239 | Resume CreateAccessFile_Exit 240 | 241 | End Sub 242 | 243 | 244 | Public Function GetForeignSysProperty(PropertyName As String, ForeignPath As String) As String 245 | 246 | On Error GoTo GetForeignSysProperty_Error 247 | 248 | If ForeignPath <> vbNullString Then 249 | 250 | Dim ForeignDB As DAO.Database 251 | Set ForeignDB = DAO.OpenDatabase(ForeignPath) 252 | 253 | If HasProperty(ForeignDB, PropertyName) Then 254 | GetForeignSysProperty = ForeignDB.Properties(PropertyName) 255 | End If 256 | 257 | End If 258 | 259 | GetForeignSysProperty_Exit: 260 | 261 | If ForeignPath <> vbNullString Then ForeignDB.Close 262 | Exit Function 263 | 264 | GetForeignSysProperty_Error: 265 | ErrorLogger.LogError Err.Number, Err.Description, "GetProperty" 266 | Resume GetForeignSysProperty_Exit 267 | 268 | End Function 269 | 270 | 271 | Public Sub LinkTable(TableName As String, Path As String) 272 | 273 | On Error GoTo LinkTable_Error 274 | 275 | Dim DB As DAO.Database 276 | Dim LinkedTable As DAO.TableDef 277 | 278 | Set DB = CurrentDb 279 | 280 | If TableExists(TableName) Then 281 | DB.TableDefs.Delete (TableName) 282 | End If 283 | 284 | Set LinkedTable = CurrentDb.CreateTableDef(TableName) 285 | 286 | With LinkedTable 287 | .Connect = ";DATABASE=" & Path 288 | .SourceTableName = TableName 289 | End With 290 | 291 | DB.TableDefs.Append LinkedTable 292 | 293 | LinkTable_Exit: 294 | 295 | Exit Sub 296 | 297 | LinkTable_Error: 298 | ErrorLogger.LogError Err.Number, Err.Description, "LinkTable" 299 | Resume LinkTable_Exit 300 | 301 | End Sub 302 | 303 | Public Sub DeleteTable(DB As Database, TableName As String) 304 | 305 | On Error GoTo DeleteTable_Error 306 | 307 | If TableExists(TableName, DB.Name) Then 308 | DB.TableDefs.Delete TableName 309 | End If 310 | 311 | DeleteTable_Exit: 312 | 313 | Exit Sub 314 | 315 | DeleteTable_Error: 316 | ErrorLogger.LogError Err.Number, Err.Description, "DeleteTable" 317 | Resume DeleteTable_Exit 318 | 319 | End Sub 320 | 321 | Public Sub CopyTable(TableName As String, TableAlias As String, Optional DatabasePath As String) 322 | 323 | On Error GoTo CopyTable_Error 324 | 325 | Dim DB As Database 326 | 327 | If DatabasePath = vbNullString Then 328 | DatabasePath = CurrentProject.Path 329 | End If 330 | 331 | If TableExists(TableAlias, DatabasePath) Then 332 | Set DB = OpenDatabase(DatabasePath) 333 | DB.TableDefs.Delete TableAlias 334 | DB.Close 335 | Set DB = Nothing 336 | End If 337 | 338 | DoCmd.TransferDatabase acImport, "Microsoft Access", DatabasePath, acTable, TableName, TableName & "_Temp", False 339 | DoCmd.TransferDatabase acExport, "Microsoft Access", DatabasePath, acTable, TableName & "_Temp", TableAlias, False 340 | DoCmd.DeleteObject acTable, TableName & "_Temp" 341 | 342 | CopyTable_Exit: 343 | 344 | Exit Sub 345 | 346 | CopyTable_Error: 347 | ErrorLogger.LogError Err.Number, Err.Description, "CopyTable" 348 | Resume CopyTable_Exit 349 | 350 | End Sub 351 | 352 | Public Sub DeleteLinkedTables() 353 | 354 | On Error GoTo DeleteLinkedTables_Error 355 | 356 | Dim LinkedTable As TableDef 357 | 358 | For Each LinkedTable In CurrentDb.TableDefs 359 | If LinkedTable.Connect <> vbNullString Then 360 | DeleteTable CurrentDb, LinkedTable.Name 361 | End If 362 | Next 363 | 364 | DeleteLinkedTables_Exit: 365 | 366 | Exit Sub 367 | 368 | DeleteLinkedTables_Error: 369 | ErrorLogger.LogError Err.Number, Err.Description, "DeleteLinkedTables" 370 | Resume DeleteLinkedTables_Exit 371 | 372 | End Sub 373 | 374 | 375 | Public Sub AutoCompactAndRepiar() 376 | 377 | 'Remember that auto-compact can be a death sentence due to backups! 378 | 'Only use this if you DEFINITELY have a network backup of the application (ideally in a VCS...) 379 | 380 | If Files.FileSize(Application.CurrentProject.FullName) > 25 Then 381 | Application.SetOption ("Auto Compact"), 1 'Compact Application 382 | Else 383 | Application.SetOption ("Auto Compact"), 0 'Don't Compact Application 384 | End If 385 | 386 | End Sub 387 | 388 | 389 | Public Sub CreateTestQuery(SQL As String, Optional QueryName As String) 390 | 391 | If QueryName = vbNullString Then 392 | QueryName = "qtmp_TestingQuery" 393 | End If 394 | 395 | If QueryExists(QueryName) Then 396 | DoCmd.DeleteObject acQuery, QueryName 397 | End If 398 | 399 | Dim NewQuery As DAO.QueryDef 400 | Set NewQuery = New DAO.QueryDef 401 | NewQuery.Name = QueryName 402 | NewQuery.SQL = SQL 403 | 404 | CurrentDb.QueryDefs.Append NewQuery 405 | CurrentDb.QueryDefs.Refresh 406 | 407 | End Sub 408 | 409 | Public Sub ShowDatabaseWindow() 410 | DoCmd.SelectObject acTable, , True 411 | End Sub 412 | 413 | Public Sub HideDatabaseWindow() 414 | DoCmd.SelectObject acTable, , True 415 | DoCmd.RunCommand acCmdWindowHide 416 | End Sub 417 | 418 | 419 | Public Sub RunScriptsFromFile(Filename As String, Database As Database) 420 | 421 | On Error GoTo ErrorHandler 422 | 423 | Dim FSO As New FileSystemObject 424 | 425 | DBEngine.BeginTrans 426 | 427 | Dim SQLCommand 428 | For Each SQLCommand In Split(FSO.OpenTextFile(Filename).ReadAll, ";") 429 | If Trim(SQLCommand) <> vbNullString Then 430 | Debug.Print SQLCommand 431 | Database.Execute SQLCommand, dbFailOnError 432 | End If 433 | Next SQLCommand 434 | 435 | DBEngine.CommitTrans 436 | 437 | Exit Sub 438 | 439 | ErrorHandler: 440 | DBEngine.Rollback 441 | 442 | End Sub 443 | 444 | 445 | Public Function LowestOf(ParamArray Inputs()) As Variant 446 | 447 | Dim Low As Variant 448 | Low = Null 449 | 450 | Dim i As Long 451 | For i = LBound(Inputs) To UBound(Inputs) 452 | If IsNumeric(Inputs(i)) Or IsDate(Inputs(i)) Then 453 | 454 | If Inputs(i) < Low Then 455 | Low = Inputs(i) 456 | End If 457 | 458 | End If 459 | Next i 460 | 461 | LowestOf = Low 462 | 463 | End Function 464 | Public Function HighestOf(ParamArray Inputs()) As Variant 465 | 466 | Dim High As Variant 467 | High = Null 468 | 469 | Dim i As Long 470 | For i = LBound(Inputs) To UBound(Inputs) 471 | If IsNumeric(Inputs(i)) Or IsDate(Inputs(i)) Then 472 | 473 | If Inputs(i) > High Then 474 | High = Inputs(i) 475 | End If 476 | 477 | End If 478 | Next i 479 | 480 | HighestOf = High 481 | 482 | End Function 483 | 484 | Public Sub SelectAllInList(ListBox As ListBox) 485 | Dim i As Long 486 | For i = 0 To ListBox.ListCount - 1 487 | ListBox.Selected(i) = True 488 | Next i 489 | End Sub 490 | Public Sub ClearAllInList(ListBox As ListBox) 491 | Dim i As Long 492 | For i = 0 To ListBox.ListCount - 1 493 | ListBox.Selected(i) = False 494 | Next i 495 | End Sub 496 | 497 | Public Sub ListIndexes() 498 | Dim t As TableDef 499 | For Each t In CurrentDb.TableDefs 500 | If Not (t.Name Like "MSys*") Then 501 | Dim i As Index 502 | For Each i In t.Indexes 503 | Debug.Print t.Name, i.Name, i.Fields, i.Primary, i.Unique, i.IgnoreNulls 504 | Next i 505 | End If 506 | Next t 507 | 508 | End Sub 509 | -------------------------------------------------------------------------------- /Modules/Files.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Files" 2 | Option Explicit 3 | 4 | Public Enum DriveType 5 | Unknown = 0 6 | Absent = 1 7 | Removable = 2 8 | Fixed = 3 9 | Remote = 4 10 | CDRom = 5 11 | RamDisk = 6 12 | End Enum 13 | 14 | 'Used to get UNC path 15 | Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" _ 16 | (ByVal LocalName As String, ByVal RemoteName As String, RemoteName As Long) As Long 17 | 18 | Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" _ 19 | (ByVal nDrive As String) As Long 20 | 21 | Private FSO As New Scripting.FileSystemObject 22 | 23 | 24 | Public Function FileExists(Location As String) As Boolean 25 | FileExists = FSO.FileExists(Location) 26 | End Function 27 | 28 | 29 | Public Function FolderExists(Location As String) As Boolean 30 | FolderExists = FSO.FolderExists(Location) 31 | End Function 32 | 33 | 34 | Public Sub DeleteFile(Location As String) 35 | If FileExists(Location) Then 36 | Kill Location 37 | End If 38 | End Sub 39 | 40 | 41 | Public Sub DeleteFolder(Location As String) 42 | If FolderExists(Location) Then 43 | FSO.DeleteFolder Location 44 | End If 45 | End Sub 46 | 47 | 48 | Public Sub CopyFile(SourceLocation As String, DestinationLocation As String) 49 | If FileExists(SourceLocation) Then 50 | FileCopy SourceLocation, DestinationLocation 51 | End If 52 | End Sub 53 | 54 | 55 | Public Sub CopyFolder(SourceLocation As String, DestinationLocation As String) 56 | 57 | If FolderExists(SourceLocation) Then 58 | If Not FolderExists(DestinationLocation) Then 59 | CreateFolder DestinationLocation 60 | End If 61 | 62 | Dim f As Folder 63 | Set f = FSO.GetFolder(SourceLocation) 64 | 65 | If f.SubFolders.Count = 0 Then 66 | FSO.CopyFolder Strings.RemovePathSeparator(Trim(SourceLocation)), Strings.RemovePathSeparator(Trim(DestinationLocation)), True 67 | Else 68 | FSO.CopyFolder Trim(SourceLocation) & "*.*", Trim(DestinationLocation), True 69 | End If 70 | End If 71 | 72 | End Sub 73 | 74 | 75 | Public Sub CreateFolder(FolderLocation As String) 76 | 77 | Dim PathParts() As String 78 | PathParts = Split(FolderLocation, "\") 79 | 80 | Dim PathPart As Variant 81 | Dim FullPath As String 82 | For Each PathPart In PathParts 83 | If Len(PathPart) > 0 Then 84 | FullPath = FullPath & PathPart & "\" 85 | If Not FolderExists(FullPath) Then 86 | MkDir FullPath 87 | End If 88 | End If 89 | Next PathPart 90 | 91 | End Sub 92 | 93 | 94 | Public Function GetFilePath(FilePath As String) As String 95 | 96 | 'Returns a directory from a filepath 97 | GetFilePath = Left$(FilePath, InStrRev(FilePath, "\")) 98 | 99 | End Function 100 | 101 | 102 | Public Function GetFileNameFromPath(Path As String) As String 103 | 104 | 'Returns a file name from a filepath - like Dir but will return the filename even for a non-existent path 105 | 106 | GetFileNameFromPath = vbNullString 107 | 108 | Dim PathArray() As String 109 | PathArray = Split(Path, "\") 110 | 111 | If PathArray(UBound(PathArray)) = vbNullString Then 112 | GetFileNameFromPath = PathArray(UBound(PathArray) - 1) 113 | Else 114 | GetFileNameFromPath = PathArray(UBound(PathArray)) 115 | End If 116 | 117 | End Function 118 | 119 | 120 | Public Function StripExtension(Filename As String) As String 121 | If InStrRev(GetFileNameFromPath(Filename), ".") = 0 Then 122 | StripExtension = Filename 123 | Else 124 | StripExtension = Left(GetFileNameFromPath(Filename), InStrRev(GetFileNameFromPath(Filename), ".") - 1) 125 | End If 126 | End Function 127 | 128 | 129 | Public Function FileList(Path As String, Optional Filter As String = "*.*") As Collection 130 | 131 | 'Returns a collection of Scripting.File objects keyed by path 132 | 133 | Dim StartingFolder As Scripting.Folder 134 | Set StartingFolder = FSO.GetFolder(Path) 135 | 136 | Set FileList = New Collection 137 | RecursiveGetFiles StartingFolder, FileList, Filter 138 | 139 | End Function 140 | 141 | 142 | Private Function RecursiveGetFiles(StartingFolder As Scripting.Folder, ByRef FullFileList As Collection, Optional Filter As String = "*.*") 143 | 144 | Dim File As Scripting.File 145 | For Each File In StartingFolder.Files 146 | If File.Name Like Filter Then 147 | FullFileList.Add File, File.Path 148 | End If 149 | Next File 150 | 151 | Dim SubFolder As Scripting.Folder 152 | For Each SubFolder In StartingFolder.SubFolders 153 | RecursiveGetFiles SubFolder, FullFileList 154 | Next SubFolder 155 | 156 | End Function 157 | 158 | 159 | Public Function GetFileOwner(FilePath As String) As String 160 | 161 | 'Returns the name of the person who currently has ownership of a file 162 | 163 | Dim File As Integer 164 | File = FreeFile(0) 165 | 166 | Open FilePath For Binary As #File 167 | 168 | Dim FileText As String 169 | FileText = Space(LOF(File)) 170 | Get File, , FileText 171 | Close #File 172 | 173 | Dim SpaceFlag As String, SpacePos As Long 174 | SpaceFlag = Space(2) 175 | SpacePos = InStr(1, FileText, SpaceFlag) 176 | 177 | Dim NullFlag As String, NameStart As Long 178 | NullFlag = vbNullChar & vbNullChar 179 | NameStart = InStrRev(FileText, NullFlag, SpacePos) + Len(NullFlag) 180 | 181 | Dim INameLen As Byte 182 | INameLen = Asc(Mid(FileText, NameStart - 3, 1)) 183 | 184 | GetFileOwner = Mid(FileText, NameStart, INameLen) 185 | 186 | End Function 187 | 188 | Public Function GetUNCPath(DriveLetter As String) As String 189 | 190 | On Local Error GoTo GetUNCPath_Err 191 | 192 | Const ERROR_BAD_DEVICE = 1200& 193 | Const ERROR_CONNECTION_UNAVAIL = 1201& 194 | Const ERROR_EXTENDED_ERROR = 1208& 195 | Const ERROR_MORE_DATA = 234 196 | Const ERROR_NOT_SUPPORTED = 50& 197 | Const ERROR_NO_NET_OR_BAD_PATH = 1203& 198 | Const ERROR_NO_NETWORK = 1222& 199 | Const ERROR_NOT_CONNECTED = 2250& 200 | Const NO_ERROR = 0 201 | 202 | Const INVALID_CHAR As Integer = 0 203 | 204 | Dim LocalName As String 205 | LocalName = Replace(UCase(DriveLetter), "\", vbNullString) 206 | If InStr(1, LocalName, ":") = 0 Then 207 | LocalName = LocalName & ":" 208 | End If 209 | 210 | Dim RemoteName As String 211 | RemoteName = Space(256) 212 | 213 | Dim RemoteNameLength As Long 214 | RemoteNameLength = Len(RemoteName) 215 | 216 | Dim ConnType As Long 217 | ConnType = WNetGetConnection(LocalName, RemoteName, RemoteNameLength) 218 | 219 | Dim Msg As String 220 | Select Case ConnType 221 | Case ERROR_BAD_DEVICE 222 | Msg = "Error: Bad Device" 223 | Case ERROR_CONNECTION_UNAVAIL 224 | Msg = "Error: Connection Un-Available" 225 | Case ERROR_EXTENDED_ERROR 226 | Msg = "Error: Extended Error" 227 | Case ERROR_MORE_DATA 228 | Msg = "Error: More Data" 229 | Case ERROR_NOT_SUPPORTED 230 | Msg = "Error: Feature not Supported" 231 | Case ERROR_NO_NET_OR_BAD_PATH 232 | Msg = "Error: No Network Available or Bad Path" 233 | Case ERROR_NO_NETWORK 234 | Msg = "Error: No Network Available" 235 | Case ERROR_NOT_CONNECTED 236 | Msg = "Error: Not Connected" 237 | Case NO_ERROR 238 | ' all is successful... 239 | End Select 240 | 241 | If ConnType <> NO_ERROR Then Err.Raise (ConnType) 242 | 243 | GetUNCPath = Replace(Trim(Left$(RemoteName, RemoteNameLength)), Chr(INVALID_CHAR), vbNullString) 244 | Exit Function 245 | 246 | GetUNCPath_Err: 247 | GetUNCPath = Msg 248 | 249 | End Function 250 | 251 | 252 | Public Function IsUNCPath(Path As String) As Boolean 253 | 254 | IsUNCPath = (Left$(Path, 2) = "\\") 255 | 256 | End Function 257 | 258 | Public Function IsLocalPath(Path As String) As Boolean 259 | ' Dim s As String 260 | ' If IsUNCPath(Path) Then 261 | ' IsLocalPath = False 262 | ' Exit Function 263 | ' Else 264 | ' s = GetUNCPath(Path) 265 | ' IsLocalPath = (s = "Error: Bad Device") 266 | ' End If 267 | IsLocalPath = Not (Left(ConvertToUNCPath(Path), 2) = "\\") 268 | End Function 269 | 270 | 271 | Public Function ConvertToUNCPath(Path As String) As String 272 | 273 | If IsUNCPath(Path) Or DriveType(Left(Path, 1)) = Fixed Then 274 | 275 | ConvertToUNCPath = Path 276 | 277 | Else 278 | 279 | Dim FirstSep As Integer 280 | FirstSep = InStr(1, Path, "\") 281 | 282 | Dim PathWithoutDrive As String 283 | PathWithoutDrive = Right(Path, Len(Path) - FirstSep) 284 | 285 | ConvertToUNCPath = GetUNCPath(Left(Path, 1)) & "\" & PathWithoutDrive 286 | 287 | End If 288 | 289 | End Function 290 | 291 | 292 | Public Function GetOpenFilename(Optional Title As String = "Select File To Open", _ 293 | Optional Filter As Variant = Empty, _ 294 | Optional FilterIndex As Variant = Empty, _ 295 | Optional InitialPath As String = vbNullString) As String 296 | 297 | On Error GoTo GetOpenFileName_Error 298 | 299 | Dim fd As Office.FileDialog 300 | Set fd = Application.FileDialog(msoFileDialogFilePicker) 301 | With fd 302 | .Title = Title 303 | 304 | If IsArray(Filter) And IsArray(FilterIndex) Then 305 | 306 | Dim i As Integer 307 | For i = LBound(Filter) To UBound(Filter) 308 | .Filters.Add Filter(i), FilterIndex(i) 309 | Next i 310 | 311 | ElseIf Filter <> vbNullString And FilterIndex <> vbNullString Then 312 | 313 | .Filters.Add Filter, FilterIndex 314 | 315 | Else 316 | 317 | .Filters.Add "All Files", "*.*", 1 318 | 319 | End If 320 | 321 | .InitialFileName = IIf(InitialPath = vbNullString, CurrentProject.Path, InitialPath) 322 | 323 | .Show 324 | 325 | GetOpenFilename = .SelectedItems(1) 326 | 327 | End With 328 | 329 | GetOpenFileName_Exit: 330 | 331 | Exit Function 332 | 333 | GetOpenFileName_Error: 334 | 335 | GetOpenFilename = "False" 336 | GoTo GetOpenFileName_Exit 337 | 338 | End Function 339 | 340 | 341 | Public Function GetFolderName(Optional Title As String = "Select Folder", Optional InitialPath As String = vbNullString) As String 342 | 343 | On Error GoTo NothingSelected 344 | 345 | With Application.FileDialog(msoFileDialogFolderPicker) 346 | .AllowMultiSelect = False 347 | .Title = Title 348 | .InitialFileName = IIf(InitialPath = vbNullString, CurrentProject.Path, InitialPath) 349 | .Show 350 | GetFolderName = .SelectedItems(.SelectedItems.Count) 351 | End With 352 | 353 | Exit Function 354 | NothingSelected: 355 | GetFolderName = "False" 356 | 357 | End Function 358 | 359 | 360 | Public Function GetSaveAsFilename(Optional Title As String = "Save File As...", Optional InitialFileName As String = vbNullString) As String 361 | 362 | With Application.FileDialog(msoFileDialogSaveAs) 363 | 364 | .AllowMultiSelect = False 365 | .Title = Title 366 | .InitialFileName = InitialFileName 367 | .Show 368 | If .SelectedItems.Count = 0 Then 369 | GetSaveAsFilename = "False" 370 | Else 371 | GetSaveAsFilename = .SelectedItems(.SelectedItems.Count) 372 | End If 373 | 374 | End With 375 | 376 | End Function 377 | 378 | 379 | Public Function FileSize(Path As String) As Double 380 | 381 | Dim File As Object 382 | Set File = FSO.GetFile(Path) 383 | 384 | FileSize = File.Size / 10 ^ 6 385 | 386 | End Function 387 | 388 | 389 | Public Sub CreateTextFile(Location As String, Optional TextToWrite As String) 390 | 391 | CreateFolder (Left(Location, InStrRev(Location, "\"))) 392 | 393 | Dim t As TextStream 394 | Set t = FSO.CreateTextFile(Location, True) 395 | 396 | If TextToWrite <> vbNullString Then 397 | t.Write TextToWrite 398 | End If 399 | 400 | t.Close 401 | 402 | End Sub 403 | 404 | Public Sub ReplaceTextInFile(Path As String, OldText As String, NewText As String) 405 | 406 | Dim OldFile As TextStream 407 | Set OldFile = FSO.OpenTextFile(Path, ForReading, False, TristateUseDefault) 408 | 409 | Dim NewFileContent As String 410 | NewFileContent = Replace(OldFile.ReadAll, OldText, NewText) 411 | 412 | OldFile.Close 413 | Kill Path 414 | 415 | Dim NewFile As TextStream 416 | Set NewFile = FSO.CreateTextFile(Path, True) 417 | 418 | NewFile.Write NewFileContent 419 | NewFile.Close 420 | 421 | End Sub 422 | 423 | 424 | Public Function FileLocked(FilePath As String) As Boolean 425 | 426 | On Error GoTo Locked 427 | 428 | Dim FileNumber As Integer 429 | FileNumber = FreeFile(0) 430 | 431 | Open FilePath For Binary Access Read Write Lock Read Write As #FileNumber 432 | Close #FileNumber 433 | FileLocked = False 434 | 435 | Exit Function 436 | 437 | Locked: 438 | FileLocked = True 439 | 440 | End Function 441 | 442 | Public Function LastModified(FilePath As String) As Date 443 | LastModified = FileDateTime(FilePath) 444 | End Function 445 | 446 | Public Sub SelectFile(FilePath As String) 447 | If FileExists(FilePath) Then 448 | Shell "explorer.exe /select , " & FilePath, vbNormalFocus 449 | End If 450 | End Sub 451 | 452 | Public Function GetUniqueSaveFileName(Optional Title As String = "Save File As...", Optional InitialFileName As String = vbNullString) As String 453 | 454 | Do While True 455 | 456 | Dim InitialFilePath As String 457 | If GetUniqueSaveFileName = vbNullString Then 458 | InitialFilePath = InitialFileName 459 | Else 460 | InitialFilePath = GetUniqueSaveFileName 461 | End If 462 | 463 | GetUniqueSaveFileName = _ 464 | GetSaveAsFilename( _ 465 | Title, _ 466 | InitialFilePath _ 467 | ) 468 | If GetUniqueSaveFileName = "False" Then Exit Function 469 | 470 | If Files.FileLocked(GetUniqueSaveFileName) Then 471 | MsgBox "File currently in use. Please use a different file name.", vbInformation, "Error" 472 | Else 473 | Exit Do 474 | End If 475 | 476 | Loop 477 | 478 | End Function 479 | 480 | 481 | Public Function DriveType(DriveLetter As String) As DriveType 482 | DriveType = GetDriveType(Left(DriveLetter, 1) & ":") 483 | End Function 484 | --------------------------------------------------------------------------------