|
<< Click to Display Table of Contents >> VBA Helper Functions |
  
|
|
<< Click to Display Table of Contents >> VBA Helper Functions |
|
Option Explicit
'***************************************************************
'* *
'* SYNKRONIZER 11 *
'* HELPER PROCEDURES/FUNCTIONS *
'* *
'* - requires a DEVELOPER license of Synkronizer 11 *
'* - requires a reference to 'Synkronizer 11 Object Library *
'* *
'***************************************************************
Public snk As Synkronizer.Application
'------------------------------------------------------------
'this wrapper procedure initializes the Synkronizer application object
Public Sub InitSnk(Optional bWithUI As Boolean = False)
If snk Is Nothing Then
Dim cai As COMAddIn
Set cai = Application.COMAddIns("Synkronizer.Addin")
If Not cai.Connect Then
'see documentation if following throws permission errors
'Note:
'During setup the Addin is installed for All Users by writing
'the instructions to the registry under
'HKLM\Software\Microsoft\Office\Excel\Addins
'Your code should always test that the ComAddin.
'Connect property returns TRUE.
'If it returns FALSE, then you can activate the addin
'from Comaddin Dialog: If you want your code to change
'the ComAddin.Connect property, then it must be loaded
'from HKCU (Current user). To make the necessary registry
'changes we've provided the AddinLoad.bat batch file
'in the installation folder.
cai.Connect = True
End If
Set snk = cai.Object
End If
'Ensure any existing project is silently closed
If Not bWithUI And snk.DisplayUI Then
'hiding the UI will dispose the project
snk.DisplayUI = False
ElseIf bWithUI And Not snk.DisplayUI Then
snk.DisplayUI = True
End If
End Sub
'------------------------------------------------------------
'this procedure closes a project
Public Sub CloseProject()
If Not snk.ActiveProject Is Nothing Then
If Not snk.ActiveProject.IsDisposed Then
snk.ActiveProject.Close CloseFiles:=False, DisplayUndo:=False
End If
End If
End Sub
'----------------------------------------------------
'this procedure checks if the defined
'folders & files are valid
Public Sub Check_Folders_File()
'check folders
If ROOT <> "" Then Debug.Assert Len(Dir(ROOT, vbDirectory)) > 0
If FOLDERSRC <> "" Then Debug.Assert Len(Dir(FOLDERSRC, vbDirectory)) > 0
If FOLDERTGT <> "" Then Debug.Assert Len(Dir(FOLDERTGT, vbDirectory)) > 0
If FOLDERREP <> "" Then Debug.Assert Len(Dir(FOLDERREP, vbDirectory)) > 0
If FOLDERPRJ <> "" Then Debug.Assert Len(Dir(FOLDERPRJ, vbDirectory)) > 0
If FOLDERLOG <> "" Then Debug.Assert Len(Dir(FOLDERLOG, vbDirectory)) > 0
'check files
If FILESRC <> "" Then Debug.Assert Len(Dir(FILESRC)) > 0
If FILETGT <> "" Then Debug.Assert Len(Dir(FILETGT)) > 0
If PROTSRC <> "" Then Debug.Assert Len(Dir(PROTSRC)) > 0
If PROTTGT <> "" Then Debug.Assert Len(Dir(PROTTGT)) > 0
End Sub
'---------------------------------------------------------------
'this function returns the not matched files
Public Function Get_NotMatchedWorksheets(sSrcFolder As String, sTgtFolder As String) As Variant
ReDim aFiles(0) As String
ReDim aNotMatched(0) As String
Dim sFile As String
Dim i, j As Integer
For i = 1 To 2
sFile = Dir(Choose(3 - i, sSrcFolder, sTgtFolder) & "*.xls*")
Do While Len(sFile) > 0
ReDim Preserve aFiles(UBound(aFiles) + 1)
aFiles(UBound(aFiles)) = sFile
sFile = Dir
Loop
For j = 1 To UBound(aFiles)
If Len(Dir(Choose(i, sSrcFolder, sTgtFolder) & aFiles(j))) = 0 Then
ReDim Preserve aNotMatched(UBound(aNotMatched) + 1)
aNotMatched(UBound(aNotMatched)) = Choose(i, sSrcFolder, sTgtFolder) & aFiles(j)
End If
Next j
ReDim aFiles(0)
Next i
Get_NotMatchedWorksheets = aNotMatched
End Function
'---------------------------------------------------------------
'this function returns the differences of a project
'if on pair is compared, all detailed differences are returned
'if multiple pairs are compared, the total differences per pair are returned
Public Function GetDifferences(oProj As Project) As String
Dim p As Pair
Dim sMsg As String
Dim i As Integer
If oProj.Pairs.Count = 1 Then
'one pair » return detailed differences
sMsg = oProj.Results.SumText
Else
'multiple pairs » return total differences per pair
i = 1
For Each p In oProj.Pairs
sMsg = sMsg & p.SheetName(sideID_src) & vbTab & _
p.Results.Sum & vbNewLine
i = i + 1
If i > 20 Then Exit For
Next p
'just display the first 20 pairs...
If i > 20 Then
sMsg = sMsg & "..." & vbNewLine
End If
End If
GetDifferences = sMsg
End Function
'---------------------------------------------------------------
'this function compares the files of two folders
'
'Parameter description
'Paramater description:
'sFolderSrc: Folder with source files to be compared
'sFolderTgt: Folder with target files to be compared
'bHighlight: Select True if differences should be highlighted
'sFolderLog: If difference reports are needed, enter folder. Optional.
'sFolderLog: If a log file is needed, enter folder. Optional
Public Function SynkFolders(sFolderSrc As String, _
sFolderTgt As String, _
bHighlight As Boolean, _
Optional sFolderRep As String, _
Optional sFolderLog As String) As String
Dim oProj As Synkronizer.Project
Dim sFile As String
Dim aFiles() As String
Dim i As Integer
Dim j As Integer
Dim sFileSrc As String
Dim sFileTgt As String
Dim sFileRep As String
Dim sFileLog As String
Dim vNotMatchedFiles As Variant
Dim n(0 To 1) As Long
Dim t0 As Date
'check if folders are valid
Debug.Assert Len(Dir(sFolderSrc, vbDirectory))
Debug.Assert Len(Dir(sFolderTgt, vbDirectory))
If sFolderRep <> "" Then Debug.Assert Len(Dir(sFolderRep, vbDirectory))
If sFolderLog <> "" Then Debug.Assert Len(Dir(sFolderLog, vbDirectory))
t0 = Timer
On Error GoTo theExit
'check if defined constants are valid
Check_Folders_File
'get access to the Synkronizer application object
InitSnk
'create log file
If sFolderLog <> "" Then
sFileLog = sFolderLog & "\synkronizer_log_" & Format(Now, "yyyy-mm-dd_HH-MM-SS") & ".txt"
Reset
Open sFileLog For Output As #1
Print #1, "Synkronizer Logfile"
Print #1, "-------------------"
Print #1, ""
Print #1, "Date: " & Format(Date, "yyyy-mm-dd")
Print #1, "Time: " & Format(Time, "hh:nn:ss")
Print #1, ""
Print #1, ""
End If
'read "source" files
i = 0
sFile = Dir(sFolderSrc & "*.xls*")
Do While Len(sFile) > 0
ReDim Preserve aFiles(i)
aFiles(i) = sFile
i = i + 1
sFile = Dir
Loop
'log not matched worksheets
vNotMatchedFiles = Get_NotMatchedWorksheets(sFolderSrc, sFolderTgt)
If UBound(vNotMatchedFiles) > 0 Then
Print #1, "Not matched files"
For i = 1 To UBound(vNotMatchedFiles)
Print #1, vNotMatchedFiles(i)
Next i
Print #1, ""
Print #1, ""
End If
'loop all "source" files
For i = 0 To UBound(aFiles)
sFileSrc = sFolderSrc & aFiles(i)
sFileTgt = sFolderTgt & aFiles(i)
sFileRep = sFolderRep & "Difference Report " & aFiles(i)
sFileRep = Left(sFileRep, InStrRev(sFileRep, ".") - 1) & ".xlsx"
'check if "target" is there
If Len(Dir(sFileTgt)) > 0 Then
'create new project
Set oProj = snk.NewProject
With oProj
'load files
.Files.Load sFileSrc, sFileTgt
'match all worksheets with same name
With .Pairs
.MatchType = MatchType_AllByName
.MatchInclude = MatchIncludeFlag_HiddenSheets + MatchIncludeFlag_ProtectedSheets
.AddMatched
End With
'highlight & create report
With .Settings
If bHighlight Then .Highlight = HighlightType_Standard
If sFolderRep <> "" Then .Report = ReportType_Standard
End With
'compare!
.Execute
'log differences
If sFolderLog <> "" Then
'Print #1, aFiles(i) & vbTab & .Results.Sum
Call Logfile_PrintDiffs(oProj)
End If
If .Results.Sum Then
'if differences found, create report
n(1) = n(1) + 1
If sFolderRep <> "" Then
If Len(Dir(sFileRep)) > 0 Then Kill sFileRep
With .ReportWorkbook
.SaveAs file name:=sFileRep
End With
End If
Else
'no differences noted; close report without saving
n(0) = n(0) + 1
End If
'save files if differences are highlighted
If bHighlight Then
If .Files.Workbook(sideID_src).FullName <> sFileSrc Then
.Files.Workbook(sideID_src).SaveCopyAs sFileSrc
Else
.Files.Workbook(sideID_src).Save
End If
If .Files.Workbook(sideID_tgt).FullName <> sFileTgt Then
.Files.Workbook(sideID_tgt).SaveCopyAs sFileTgt
Else
.Files.Workbook(sideID_tgt).Save
End If
End If
.Close CloseFiles:=True, DisplayUndo:=False
DoEvents
End With
Set oProj = Nothing
DoEvents
End If
Next i
'create end message in log file
If sFolderLog <> "" Then
Print #1, ""
Print #1, "Comparison time: " & Format(Timer - t0, " 00.00\s\")
Reset
End If
'display end message
SynkFolders = "finished" & vbLf & _
n(0) & " workbooks without differences" & vbLf & _
n(1) & " workbooks with differences, see reports"
theExit:
Reset
Set oProj = Nothing
Set snk = Nothing
Exit Function
theError:
Dim sErr As String
sErr = Err.Number & ": " & Err.Description
On Error Resume Next
If Not oProj Is Nothing Then
oProj.Close True, False
End If
SynkFolders = sErr
Resume theExit
End Function
'---------------------------------------------------------------
'this function compares one source file against all files of a target folder
'
'Paramater description:
'sFileSrc: Source file
'sFolderTgt: Folder with target files to be compared
'bHighlight: Select True if differences should be highlighted
'sFolderLog: If difference reports are needed, enter folder. Optional.
'sFolderLog: If a log file is needed, enter folder. Optional
Public Function SynkSrcFolder(sFileSrc As String, _
sFolderTgt As String, _
bHighlight As Boolean, _
Optional sFolderRep As String, _
Optional sFolderLog As String) As String
Dim oProj As Synkronizer.Project
Dim aFiles() As String
Dim i As Integer
Dim sFile As String
Dim sFileTgt As String
Dim sFileRep As String
Dim sFileLog As String
Dim n(0 To 1) As Long
Dim t0 As Date
'check if files/folders are valid
Debug.Assert Len(Dir(sFileSrc, vbDirectory))
Debug.Assert Len(Dir(sFolderTgt, vbDirectory))
If sFolderRep <> "" Then Debug.Assert Len(Dir(sFolderRep, vbDirectory))
If sFolderLog <> "" Then Debug.Assert Len(Dir(sFolderLog, vbDirectory))
t0 = Timer
On Error GoTo theError
'check if defined constants are valid
Check_Folders_File
'get access to the Synkronizer application object
InitSnk
'create log file
If sFolderLog <> "" Then
sFileLog = sFolderLog & "\synkronizer_log_" & Format(Now, "yyyy-mm-dd_HH-MM-SS") & ".txt"
Reset
Open sFileLog For Output As #1
Print #1, "Synkronizer Logfile"
Print #1, "-------------------"
Print #1, ""
Print #1, "Date: " & Format(Date, "yyyy-mm-dd")
Print #1, "Time: " & Format(Time, "hh:nn:ss")
Print #1, ""
Print #1, ""
End If
'read "target" files
i = 0
sFile = Dir(sFolderTgt & "*.xls*")
Do While Len(sFile) > 0
ReDim Preserve aFiles(i)
aFiles(i) = sFile
i = i + 1
sFile = Dir
Loop
'loop all files
For i = 0 To UBound(aFiles)
sFileTgt = sFolderTgt & aFiles(i)
sFileRep = sFolderRep & "Difference Report " & aFiles(i)
sFileRep = Left(sFileRep, InStrRev(sFileRep, ".") - 1) & ".xlsx"
'create new project
Set oProj = snk.NewProject
With oProj
'load files
.Files.Load sFileSrc, sFileTgt
'match all worksheets with same name
With .Pairs
.MatchType = MatchType_AllByName
.MatchInclude = MatchIncludeFlag_HiddenSheets + MatchIncludeFlag_ProtectedSheets
.AddMatched
End With
'highlight & create report
With .Settings
If bHighlight Then .Highlight = HighlightType_Standard
If sFolderRep <> "" Then .Report = ReportType_Standard
End With
'compare!
.Execute
'log differences
If sFolderLog <> "" Then
'Print #1, aFiles(i) & vbTab & .Results.Sum
Call Logfile_PrintDiffs(oProj)
End If
If .Results.Sum Then
'if differences found, create report
n(1) = n(1) + 1
If sFolderRep <> "" Then
If Len(Dir(sFileRep)) > 0 Then Kill sFileRep
If Not .ReportWorkbook Is Nothing Then
With .ReportWorkbook
.SaveAs file name:=sFileRep
End With
End If
End If
Else
'no differences noted; close report without saving
n(0) = n(0) + 1
End If
'save target file if differences are highlighted
If bHighlight Then
If .Files.Workbook(sideID_tgt).FullName <> sFileTgt Then
.Files.Workbook(sideID_tgt).SaveCopyAs sFileTgt
Else
.Files.Workbook(sideID_tgt).Save
End If
'.Files.Workbook(sideID_tgt).Save
End If
.Close CloseFiles:=True, DisplayUndo:=False
DoEvents
End With
Set oProj = Nothing
Next i
'return value
SynkSrcFolder = "finished" & vbLf & _
n(0) & " workbooks without differences" & vbLf & _
n(1) & " workbooks with differences, see reports"
'write end message in log file
If sFolderLog <> "" Then
Print #1, ""
Print #1, "Comparison time: " & Format(Timer - t0, " 00.00\s\")
Reset
End If
theExit:
Reset
Set oProj = Nothing
Set snk = Nothing
Exit Function
theError:
Dim sErr As String
sErr = Err.Number & ": " & Err.Description
On Error Resume Next
If Not oProj Is Nothing Then
oProj.Close True, False
End If
SynkSrcFolder = sErr
Resume theExit
End Function
'---------------------------------------------------------------
'this procedure writes all project differences in a new workbook
Public Sub DumpDetails_Project(oProj As Synkronizer.Project)
Dim wkb As Workbook
Dim wks As Worksheet
Dim val As Variant
Dim rng As Range
Dim p As Pair
Dim iWksCount As Integer
Debug.Assert Not oProj Is Nothing
Debug.Assert Not oProj.IsDisposed
'create workbook
iWksCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set wkb = Workbooks.Add
Application.SheetsInNewWorkbook = iWksCount
Set wks = wkb.Worksheets(1)
'name worksheet
wks.Name = "Project Differences"
val = oProj.Results.ArrayDetails
If wks.UsedRange.Cells.CountLarge = 1 Then
Set rng = wks.Cells(1)
Else
With wks.UsedRange
Set rng = wks.Cells(.Row + .Rows.Count, .Column)
End With
End If
If IsEmpty(val) Then
rng.Offset(0, 0).Value = "no diffs"
Else
Set rng = rng.Offset(0, 0).Resize(UBound(val, 1) + 1, UBound(val, 2) + 1)
rng.Clear
rng.Resize(, 11).NumberFormat = "@"
rng.Resize(, 4).HorizontalAlignment = xlLeft
rng.VerticalAlignment = xlTop
rng.Value2 = val
End If
'format range
With rng
.Rows(1).Font.Bold = True
.Columns("I:K").HorizontalAlignment = xlRight
.Columns("A").ColumnWidth = 20
.Columns("B:K").ColumnWidth = 8
.Columns("D:E").ColumnWidth = 32
.Columns("F:H").ColumnWidth = 18
.Columns("F:G").EntireColumn.Hidden = True
For Each p In oProj.Pairs
If p.DBKeys <> "" Then
.Columns("F:G").EntireColumn.Hidden = False
Exit For
End If
Next p
End With
DoEvents
Application.ScreenUpdating = True
End Sub
'---------------------------------------------------------------
'this procedure creates a new workbook and
'writes all pair differences in a separate worksheet
Public Sub DumpDetails_Pairs(oProj As Synkronizer.Project)
Dim wkb As Workbook
Dim wks As Worksheet
Dim p As Pair
Dim iPair As Integer
Dim val As Variant
Dim rng As Range
Dim iWksCount As Integer
'check if project is active
Debug.Assert Not oProj Is Nothing
Debug.Assert Not oProj.IsDisposed
'create workbook
iWksCount = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = oProj.Pairs.Count
Set wkb = Workbooks.Add
Application.SheetsInNewWorkbook = iWksCount
'loop through pairs
iPair = 1
For Each p In oProj.Pairs
'name worksheet
Set wks = wkb.Worksheets(iPair)
wks.Name = p.SheetName(0)
'get results
val = p.Results.ArrayDetails
Set rng = wks.Cells(1)
'write title
With rng
.Value = p.SheetName(0)
.Font.Size = 12
.Font.Bold = True
End With
'write down differences
If IsEmpty(val) Then
'no differences found
rng.Offset(2, 0).Value = "no diffs"
Else
'differences found
Set rng = rng.Offset(2, 0).Resize(UBound(val, 1) + 1, UBound(val, 2) + 1)
rng.Clear
rng.Resize(, 6).NumberFormat = "@"
rng.Resize(, 2).HorizontalAlignment = xlLeft
rng.VerticalAlignment = xlTop
rng.Value2 = val
End If
val = Empty
'format range
With rng
.Rows(1).Font.Bold = True
.Columns("I:K").HorizontalAlignment = xlRight
.Columns("A").ColumnWidth = 20
.Columns("B:K").ColumnWidth = 8
.Columns("D:E").ColumnWidth = 32
.Columns("F:H").ColumnWidth = 18
If p.DBKeys = "" Then
.Columns("F:H").EntireColumn.Hidden = True
End If
End With
iPair = iPair + 1
Next p
DoEvents
Application.ScreenUpdating = True
End Sub
'---------------------------------------------------------------
'this procedure creates a log file with all differences
Public Sub Logfile_PrintDiffs(oProj As Synkronizer.Project)
Dim p As Pair
Dim sText As String
Dim sLine As String
'source file
sText = "Source File"
sLine = sText & String(34 - Len(sText), " ") & oProj.Files(sideID_src)
Print #1, sLine
'target file
sText = "Target File"
sLine = sText & String(34 - Len(sText), " ") & oProj.Files(sideID_tgt)
Print #1, sLine
'--------------------------------------------------------------
'heading row differences
sText = "Worksheet names"
sLine = sText & String(32 - Len(sText), " ")
sLine = sLine & " Total"
sLine = sLine & _
" Columns" & _
" DupRecs" & _
" DupKeys" & _
" Rows" & _
" Contents" & _
" Values"
If CBool(oProj.Settings.Formats And FormatFlag_Enabled) Then
sLine = sLine & " Formats"
End If
If CBool(oProj.Settings.Contents And ContentFlag_Comments) Then
sLine = sLine & " Comments"
End If
If CBool(oProj.Settings.Contents And ContentFlag_Names) Then
sLine = sLine & " Names"
End If
Print #1, sLine
'--------------------------------------------------------------
'pair differences
For Each p In oProj.Pairs
With p.Results
sText = p.SheetName(sideID_src)
sLine = sText & String(32 - Len(sText), " ")
sText = CStr(.Sum)
sLine = sLine & String(7 - Len(sText), " ") & sText
sText = .SumTextByType(ResultType_MissingCol)
sLine = sLine & String(9 - Len(sText), " ") & sText
sText = .SumTextByType(ResultType_DuplicateRec)
sLine = sLine & String(9 - Len(sText), " ") & sText
sText = .SumTextByType(ResultType_DuplicateKey)
sLine = sLine & String(9 - Len(sText), " ") & sText
sText = .SumTextByType(ResultType_MissingRow)
sLine = sLine & String(9 - Len(sText), " ") & sText
sText = .SumTextByType(ResultType_DifferentContent)
sLine = sLine & String(9 - Len(sText), " ") & sText
sText = .SumTextByType(ResultType_DifferentValue)
sLine = sLine & String(9 - Len(sText), " ") & sText
If CBool(oProj.Settings.Formats And FormatFlag_Enabled) Then
sText = .SumTextByType(ResultType_DifferentFormat)
sLine = sLine & String(9 - Len(sText), " ") & sText
End If
If CBool(oProj.Settings.Contents And ContentFlag_Comments) Then
sText = .SumTextByType(ResultType_DifferentComment)
sLine = sLine & String(9 - Len(sText), " ") & sText
End If
If CBool(oProj.Settings.Contents And ContentFlag_Names) Then
sText = .SumTextByType(ResultType_DifferentName)
sLine = sLine & String(9 - Len(sText), " ") & sText
End If
Print #1, sLine
End With
Next p
'--------------------------------------------------------------
'total differences
If oProj.Pairs.Count > 1 Then
With oProj.Results
sText = "Total"
sLine = sText & String(32 - Len(sText), " ")
sText = CStr(.Sum)
sLine = sLine & String(7 - Len(sText), " ") & sText
sText = .SumTextByType(ResultType_MissingCol)
sLine = sLine & String(9 - Len(sText), " ") & sText
sText = .SumTextByType(ResultType_DuplicateRec)
sLine = sLine & String(9 - Len(sText), " ") & sText
sText = .SumTextByType(ResultType_DuplicateKey)
sLine = sLine & String(9 - Len(sText), " ") & sText
sText = .SumTextByType(ResultType_MissingRow)
sLine = sLine & String(9 - Len(sText), " ") & sText
sText = .SumTextByType(ResultType_DifferentContent)
sLine = sLine & String(9 - Len(sText), " ") & sText
sText = .SumTextByType(ResultType_DifferentValue)
sLine = sLine & String(9 - Len(sText), " ") & sText
If CBool(oProj.Settings.Formats And FormatFlag_Enabled) Then
sText = .SumTextByType(ResultType_DifferentFormat)
sLine = sLine & String(9 - Len(sText), " ") & sText
End If
If CBool(oProj.Settings.Contents And ContentFlag_Comments) Then
sText = .SumTextByType(ResultType_DifferentComment)
sLine = sLine & String(9 - Len(sText), " ") & sText
End If
If CBool(oProj.Settings.Contents And ContentFlag_Names) Then
sText = .SumTextByType(ResultType_DifferentName)
sLine = sLine & String(9 - Len(sText), " ") & sText
End If
Print #1, sLine
End With
End If
Print #1, ""
Print #1, ""
End Sub