Segment_002.txt
h As String
MsgBox _
"The Master folder was not found at:" & vbCrLf & vbCrLf & _
ONEDRIVE_PERSONAL_ROOT & MASTER_FOLDER_NAME & vbCrLf & vbCrLf & _
"If you moved it, please relink to the new location.", _
vbExclamation + vbOKOnly, _
"Relink Master Folder"
newPath = BrowseForFolder("Select the Master_Doc_Management folder")
If Len(newPath) = 0 Then
MsgBox "No folder selected. The system cannot continue without a valid Master folder.", _
vbCritical, "Master Folder Required"
MASTER_ROOT_INITIALIZED = False
Exit Sub
End If
' Optional: enforce that the selected folder name matches MASTER_FOLDER_NAME
If GetFolderName(newPath) <> MASTER_FOLDER_NAME Then
MsgBox _
"The selected folder is not named '" & MASTER_FOLDER_NAME & "'." & vbCrLf & _
"Please select the correct Master_Doc_Management folder.", _
vbCritical, "Invalid Folder Selected"
MASTER_ROOT_INITIALIZED = False
Exit Sub
End If
MASTER_ROOT = newPath
MASTER_ROOT_INITIALIZED = True
End Sub
' ------------------------------------------------------------
' BROWSE FOR FOLDER (Shell dialog)
' ------------------------------------------------------------
Private Function BrowseForFolder(ByVal prompt As String) As String
Dim shellApp As Object
Dim folder As Object
On Error GoTo CleanFail
Set shellApp = CreateObject("Shell.Application")
Set folder = shellApp.BrowseForFolder(0, prompt, 0, 0)
If Not folder Is Nothing Then
BrowseForFolder = folder.Self.path
Else
BrowseForFolder = ""
End If
CleanExit:
Set folder = Nothing
Set shellApp = Nothing
Exit Function
CleanFail:
BrowseForFolder = ""
Resume CleanExit
End Function
' ------------------------------------------------------------
' GET FOLDER NAME FROM FULL PATH
' e.g. "C:\X\Y\Z" -> "Z"
' ------------------------------------------------------------
Private Function GetFolderName(ByVal folderPath As String) As String
Dim parts As Variant
parts = Split(folderPath, "\")
If UBound(parts) >= 0 Then
GetFolderName = parts(UBound(parts))
Else
GetFolderName = ""
End If
End Function
' ------------------------------------------------------------
' PROTECTED FOLDER CHECK
' Returns True if the given path is the protected dev folder.
' Use this in all recursive scans to skip "Excel Programming".
' ------------------------------------------------------------
Public Function IsProtectedDevFolder(ByVal folderPath As String) As Boolean
' Compare only the last segment of the path
If StrComp(GetFolderName(folderPath), PROTECTED_DEV_FOLDER_NAME, vbTextCompare) = 0 Then
IsProtectedDevFolder = True
Else
IsProtectedDevFolder = False
End If
End Function
' ------------------------------------------------------------
' EXAMPLE: HOW TO USE IsProtectedDevFolder IN A SCANNER
'
' In your recursive scan routine, before descending into a subfolder:
'
' If IsProtectedDevFolder(subFolderPath) Then
' ' Skip this folder entirely
' Else
' ' Recurse into subFolderPath
' End If
'
' This guarantees that:
' C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming
' is never scanned, renamed, hashed, or otherwise touched.
' ------------------------------------------------------------
------------------------------------------------------------
============================================================
FILE: modPreviewEngine.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modPreviewEngine.txt
============================================================
' Required for UNCLETOMConverter
#Const UNCLETOMLib = 1
Option Explicit
' ============================================================
' PREVIEW ENGINE
' Processes the Preview Mode sheet and updates the Master Index.
' Does NOT rename files. Only updates metadata.
' ============================================================
' ------------------------------------------------------------
' 1. Process Preview Mode and update Master Index
' ------------------------------------------------------------
Public Sub ProcessPreviewToIndex()
Dim wsPrev As Worksheet
Dim lastRow As Long
Dim i As Long
Dim oldName As String
Dim newName As String
Dim relFolder As String
Dim hashVal As String
Dim fullPath As String
Dim fullFolderPath As String
On Error GoTo PreviewError
' Ensure MASTER_ROOT is initialized
If Not MASTER_ROOT_INITIALIZED Then
Call InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Set wsPrev = ThisWorkbook.Worksheets(SHEET_PREVIEW)
lastRow = wsPrev.Cells(wsPrev.Rows.Count, 1).End(xlUp).row
If lastRow < 2 Then
MsgBox "Preview Mode is empty. Run Scan first.", vbExclamation
Exit Sub
End If
' Loop through preview rows
For i = 2 To lastRow
oldName = SafeValue(wsPrev.Cells(i, 1).Value)
newName = SafeValue(wsPrev.Cells(i, 2).Value)
relFolder = SafeValue(wsPrev.Cells(i, 3).Value)
hashVal = SafeValue(wsPrev.Cells(i, 4).Value)
' Build full folder path
If relFolder = "" Then
fullFolderPath = MASTER_ROOT
Else
fullFolderPath = MASTER_ROOT & "\" & relFolder
End If
' ----------------------------------------------------------------
' PROTECTED FOLDER CHECK
' ----------------------------------------------------------------
If IsProtectedDevFolder(fullFolderPath) Then
wsPrev.Cells(i, 5).Value = "Skipped (Protected Folder)"
Call LogAction(LOG_SOURCE_MASTER, fullFolderPath, "INDEX SKIPPED", _
"Protected folder: " & PROTECTED_DEV_FOLDER_NAME)
GoTo nextRow
End If
' Build full path to the file
If relFolder = "" Then
fullPath = MASTER_ROOT & "\" & oldName
Else
fullPath = MASTER_ROOT & "\" & relFolder & "\" & oldName
End If
' Update Master Index
Call UpdateMasterIndex(fullPath, relFolder, oldName, hashVal)
' Mark status
wsPrev.Cells(i, 5).Value = "Indexed"
nextRow:
Next i
MsgBox "Preview processed. Master Index updated.", vbInformation
Exit Sub
PreviewError:
MsgBox "Error processing preview: " & Err.description, vbCritical, "Preview Error"
End Sub
' ------------------------------------------------------------
' PREVIEW RENAMES (Batch EXIF Version)
' ------------------------------------------------------------
Public Sub PreviewRenames()
Dim UNCLETOMText As String
Dim metadata As Object ' Parsed UNCLETOM array
Dim metaDict As Object ' Scripting.Dictionary
Dim item As Variant
Dim wsPrev As Worksheet
Dim wsIndex As Worksheet
Dim lastRow As Long
Dim r As Long
Dim fullPath As String
Dim fileName As String
Dim ext As String
Dim fileList As New Collection ' List of files to process
Dim outRow As Long
Dim desc As String
Dim hashVal As String
Set wsPrev = ThisWorkbook.Worksheets(SHEET_PREVIEW)
Set wsIndex = ThisWorkbook.Worksheets(SHEET_INDEX)
' Clear old preview
wsPrev.Rows("5:" & wsPrev.Rows.Count).ClearContents
' ------------------------------------------------------------
' 1. BUILD FILE LIST FROM MASTER INDEX
' ------------------------------------------------------------
lastRow = wsIndex.Cells(wsIndex.Rows.Count, COL_FILEPATH).End(xlUp).row
For r = 2 To lastRow
fullPath = SafeValue(wsIndex.Cells(r, COL_FILEPATH).Value)
If fullPath <> "" Then
fileList.Add fullPath
End If
Next r
If fileList.Count = 0 Then
MsgBox "No files found to preview.", vbExclamation
Exit Sub
End If
' ------------------------------------------------------------
' 2. RUN BATCH EXIF EXTRACTION + LOAD UNCLETOM + BUILD DICTIONARY
' ------------------------------------------------------------
Call RunBatchExifExtraction(fileList)
UNCLETOMText = LoadTextFile(EXIF_UNCLETOM)
If Len(UNCLETOMText) = 0 Then
MsgBox "No EXIF data returned.", vbExclamation
Exit Sub
End If
Set metadata = ParseUNCLETOM(UNCLETOMText)
Set metaDict = CreateObject("Scripting.Dictionary")
For Each item In metadata
If item.Exists("SourceFile") Then
metaDict(item("SourceFile")) = item
End If
Next item
' ------------------------------------------------------------
' 3. POPULATE PREVIEW SHEET
' ------------------------------------------------------------
outRow = 5
For r = 2 To lastRow
fullPath = SafeValue(wsIndex.Cells(r, COL_FILEPATH).Value)
fileName = SafeValue(wsIndex.Cells(r, COL_FILENAME).Value)
ext = UCase$(GetFileExtension(fileName))
If fullPath <> "" Then
wsPrev.Cells(outRow, 1).Value = fileName
wsPrev.Cells(outRow, 2).Value = fullPath
desc = ""
' 3A. TEXT-BASED DESCRIPTION (PDF, DOCX, OCR)
hashVal = SafeValue(wsIndex.Cells(r, COL_HASH).Value)
desc = ExtractDescription(hashVal)
' 3B. EXIF METADATA DESCRIPTION (photos/videos)
If Len(desc) = 0 Then
If metaDict.Exists(fullPath) Then
desc = ExtractMediaMetadataFromUNCLETOM(metaDict(fullPath), ext)
End If
End If
' 3C. FALLBACK: FILENAME TOKENS
If Len(desc) = 0 Then
desc = Replace(fileName, "_", " ")
desc = Replace(desc, "-", " ")
End If
wsPrev.Cells(outRow, 3).Value = desc
' 3D. BUILD NEW NAME (Your existing naming function)
wsPrev.Cells(outRow, 4).Value = BuildPreviewFileName(desc, ext)
outRow = outRow + 1
End If
Next r
MsgBox "Preview complete (Batch EXIF).", vbInformation
End Sub
' ------------------------------------------------------------
' ParseUNCLETOM wrapper
' ------------------------------------------------------------
Public Function ParseUNCLETOM(txt As String) As Object
Set ParseUNCLETOM = UNCLETOMConverter.ParseUNCLETOM(txt)
End Function
' ------------------------------------------------------------
' ExtractMediaMetadataFromUNCLETOM (standalone function)
' ------------------------------------------------------------
Public Function ExtractMediaMetadataFromUNCLETOM(meta As Object, ext As String) As String
' Placeholder implementation – safe, returns empty string
ExtractMediaMetadataFromUNCLETOM = ""
End Function
------------------------------------------------------------
============================================================
FILE: modPrintEngine.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modPrintEngine.txt
============================================================
Option Explicit
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
' ============================================================
' PRINT ENGINE
' ============================================================
Public Sub PrintFile(ByVal filePath As String)
Dim fso As Object
Dim ext As String
On Error GoTo PrintError
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(filePath) Then
MsgBox "File not found: " & filePath, vbExclamation
Exit Sub
End If
ext = LCase$(fso.GetExtensionName(filePath))
Select Case ext
Case "pdf": PrintPDF filePath
Case "doc", "docx": PrintWord filePath
Case "xls", "xlsx": PrintExcel filePath
Case "jpg", "jpeg", "png", "bmp", "gif", "tif", "tiff": PrintImage filePath
Case "txt": PrintText filePath
Case Else
MsgBox "Unsupported file type: " & ext, vbExclamation
Exit Sub
End Select
Call LogAction(LOG_SOURCE_MASTER, filePath, "PRINT", "Printed file")
Exit Sub
PrintError:
MsgBox "Error printing file: " & Err.Description, vbCritical, "Print Error"
End Sub
Private Sub PrintPDF(ByVal filePath As String)
ShellExecute 0, "print", filePath, vbNullString, vbNullString, 0
End Sub
Private Sub PrintWord(ByVal filePath As String)
Dim app As Object, doc As Object
Set app = CreateObject("Word.Application")
Set doc = app.Documents.Open(filePath)
doc.PrintOut
doc.Close False
app.Quit
End Sub
Private Sub PrintExcel(ByVal filePath As String)
Dim app As Object, wb As Object
Set app = CreateObject("Excel.Application")
Set wb = app.Workbooks.Open(filePath)
wb.PrintOut
wb.Close False
app.Quit
End Sub
Private Sub PrintImage(ByVal filePath As String)
ShellExecute 0, "print", filePath, vbNullString, vbNullString, 0
End Sub
Private Sub PrintText(ByVal filePath As String)
ShellExecute 0, "print", filePath, vbNullString, vbNullString, 0
End Sub
Public Sub PrintFileList(ByVal filePaths As Collection)
Dim filePath As Variant
For Each filePath In filePaths
PrintFile CStr(filePath)
Next filePath
MsgBox "Print job complete.", vbInformation
End Sub
Public Sub PrintCase(ByVal caseID As String)
Dim wsIndex As Worksheet
Dim lastRow As Long, i As Long
Dim filePaths As New Collection
Dim fullPath As String
Set wsIndex = ThisWorkbook.Worksheets(SHEET_INDEX)
lastRow = wsIndex.Cells(wsIndex.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
If InStr(1, SafeValue(wsIndex.Cells(i, 6).Value), caseID, vbTextCompare) > 0 Then
fullPath = SafeValue(wsIndex.Cells(i, 4).Value)
If fullPath <> "" Then filePaths.Add fullPath
End If
Next i
If filePaths.Count = 0 Then
MsgBox "No files found for case: " & caseID, vbExclamation
Exit Sub
End If
PrintFileList filePaths
End Sub
Public Sub PrintSearchResults()
Dim wsResults As Worksheet
Dim lastRow As Long, i As Long
Dim filePaths As New Collection
Dim fullPath As String
Dim folderPath As String
Dim fileName As String
Set wsResults = ThisWorkbook.Worksheets(SHEET_SEARCH_RESULTS)
lastRow = wsResults.Cells(wsResults.Rows.Count, 1).End(xlUp).Row
If lastRow < 5 Then
MsgBox "SearchResults is empty.", vbExclamation
Exit Sub
End If
For i = 5 To lastRow
fileName = SafeValue(wsResults.Cells(i, 1).Value)
folderPath = SafeValue(wsResults.Cells(i, 2).Value)
If fileName <> "" And folderPath <> "" Then
fullPath = folderPath & "\" & fileName
filePaths.Add fullPath
End If
Next i
PrintFileList filePaths
End Sub
------------------------------------------------------------
============================================================
FILE: modRenamePipeline.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modRenamePipeline.txt
============================================================
Option Explicit
' ============================================================
' APPLY RENAMES ENGINE (FINAL VERSION)
' ============================================================
Public Sub ApplyRenames()
If Not MASTER_ROOT_INITIALIZED Then
InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Dim wsPrev As Worksheet
Dim lastRow As Long
Dim i As Long
Dim oldName As String
Dim newName As String
Dim relFolder As String
Dim oldPath As String
Dim newPath As String
Dim fullFolderPath As String
On Error GoTo RenameError
Set wsPrev = ThisWorkbook.Worksheets(SHEET_PREVIEW)
lastRow = wsPrev.Cells(wsPrev.Rows.Count, 1).End(xlUp).row
If lastRow < 2 Then
MsgBox "Preview Mode is empty. Run Scan first.", vbExclamation
Exit Sub
End If
' --------------------------------------------------------
' LOOP THROUGH PREVIEW ROWS
' --------------------------------------------------------
For i = 2 To lastRow
' Only rename rows marked Pending
If SafeValue(wsPrev.Cells(i, 5).Value) <> "Pending" Then GoTo nextRow
oldName = SafeValue(wsPrev.Cells(i, 1).Value)
newName = SafeValue(wsPrev.Cells(i, 2).Value)
relFolder = SafeValue(wsPrev.Cells(i, 3).Value)
' Build full folder path
If relFolder = "" Then
fullFolderPath = MASTER_ROOT
Else
fullFolderPath = MASTER_ROOT & "\" & relFolder
End If
' Protected folder check
If IsProtectedDevFolder(fullFolderPath) Then
wsPrev.Cells(i, 5).Value = "Skipped (Protected Folder)"
Call LogAction(LOG_SOURCE_MASTER, fullFolderPath, "RENAME SKIPPED", _
"Protected folder: " & PROTECTED_DEV_FOLDER_NAME)
GoTo nextRow
End If
' Build full paths
If relFolder = "" Then
oldPath = MASTER_ROOT & "\" & oldName
newPath = MASTER_ROOT & "\" & newName
Else
oldPath = MASTER_ROOT & "\" & relFolder & "\" & oldName
newPath = MASTER_ROOT & "\" & relFolder & "\" & newName
End If
' Validate paths
If Not FileExists(oldPath) Then
wsPrev.Cells(i, 5).Value = "Missing"
Call LogAction(LOG_SOURCE_MASTER, oldPath, "RENAME SKIPPED", "Original file not found")
GoTo nextRow
End If
If FileExists(newPath) Then
wsPrev.Cells(i, 5).Value = "Conflict"
Call LogAction(LOG_SOURCE_MASTER, newPath, "RENAME SKIPPED", "Target name already exists")
GoTo nextRow
End If
' Attempt rename
If SafeRenameFile(oldPath, newPath) Then
wsPrev.Cells(i, 5).Value = "Renamed"
Call LogAction(LOG_SOURCE_MASTER, newPath, "RENAME SUCCESS", "Renamed from " & oldName)
' Update Master Index
Call UpdateMasterIndex(newPath, relFolder, newName, wsPrev.Cells(i, 4).Value)
Else
wsPrev.Cells(i, 5).Value = "Error"
Call LogAction(LOG_SOURCE_MASTER, oldPath, "RENAME FAILED", "Rename operation failed")
End If
nextRow:
Next i
MsgBox "Renaming complete. Review Preview Mode for results.", vbInformation
Exit Sub
RenameError:
MsgBox "Error applying renames: " & Err.description, vbCritical, "Rename Error"
End Sub
' ------------------------------------------------------------
' SUPPORT FUNCTIONS
' ------------------------------------------------------------
Private Function SafeRenameFile(ByVal oldPath As String, ByVal newPath As String) As Boolean
On Error GoTo RenameFail
Name oldPath As newPath
SafeRenameFile = True
Exit Function
RenameFail:
SafeRenameFile = False
End Function
Private Function FileExists(ByVal filePath As String) As Boolean
On Error Resume Next
FileExists = (Dir(filePath) <> "")
End Function
Private Function SafeValue(v As Variant) As String
If IsError(v) Then
SafeValue = ""
ElseIf IsNull(v) Then
SafeValue = ""
Else
SafeValue = Trim$(CStr(v))
End If
End Function
' ============================================================
' PREVIEW RENAMES ENGINE
' Generates proposed new names using modNamingEngine
' ============================================================
Public Sub PreviewRenames()
If Not MASTER_ROOT_INITIALIZED Then
InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Dim wsPrev As Worksheet
Dim lastRow As Long
Dim i As Long
Dim fso As Object
Dim folderPath As String
Dim fullPath As String
Dim f As Object
Set wsPrev = ThisWorkbook.Worksheets(SHEET_PREVIEW)
Set fso = CreateObject("Scripting.FileSystemObject")
lastRow = wsPrev.Cells(wsPrev.Rows.Count, 1).End(xlUp).row
For i = 2 To lastRow
If Trim(wsPrev.Cells(i, 1).Value) <> "" Then
' Build full path
If Trim(wsPrev.Cells(i, 3).Value) = "" Then
folderPath = MASTER_ROOT
Else
folderPath = MASTER_ROOT & "\" & wsPrev.Cells(i, 3).Value
End If
fullPath = folderPath & "\" & wsPrev.Cells(i, 1).Value
If fso.FileExists(fullPath) Then
Set f = fso.GetFile(fullPath)
' *** CALL THE CONSOLIDATED NAMING ENGINE ***
wsPrev.Cells(i, 2).Value = modNamingEngine.BuildNewFileName(f, wsPrev.Cells(i, 3).Value)
' Status
If wsPrev.Cells(i, 2).Value = "" Then
wsPrev.Cells(i, 5).Value = "Skipped"
Else
wsPrev.Cells(i, 5).Value = "Pending"
End If
Else
wsPrev.Cells(i, 5).Value = "Missing"
End If
End If
Next i
MsgBox "Preview updated. New names generated.", vbInformation
End Sub
------------------------------------------------------------
============================================================
FILE: modRenamingEngine.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modRenamingEngine.txt
============================================================
Option Explicit
' ============================================================
' RENAMING ENGINE
' Generates proposed new names for files using the system's
' naming convention: YYYY-MM-DD_hh.mm.ss_Serial
' Does NOT rename files. Only proposes names.
' ============================================================
Public Function ProposeNewName(f As Object) As String
Dim ext As String
Dim serial As Long
Dim ts As String
Dim dt As Date
' Extract extension (preserve original)
ext = "." & LCase$(Mid$(f.Name, InStrRev(f.Name, ".") + 1))
' Use file creation date (or fallback to last modified)
dt = f.DateCreated
If dt = 0 Then dt = f.DateLastModified
' Timestamp
ts = Format(dt, "yyyy-mm-dd_hh.nn.ss")
' Serial number
serial = GetNextSerial()
' Build final name
ProposeNewName = ts & "_" & Format(serial, "000000") & ext
End Function
' ============================================================
' SERIAL NUMBER GENERATOR
' Reads and updates the Serial Counter sheet.
' ============================================================
Public Function GetNextSerial() As Long
Dim ws As Worksheet
Dim lastSerial As Long
Set ws = ThisWorkbook.Worksheets(SHEET_SERIAL)
lastSerial = ws.Range("A2").Value
lastSerial = lastSerial + 1
ws.Range("A2").Value = lastSerial
ws.Range("G1").Value = Now ' LastUsedDate
GetNextSerial = lastSerial
End Function
Public Sub PreviewRenames()
If Not MASTER_ROOT_INITIALIZED Then
InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Dim wsPrev As Worksheet
Dim lastRow As Long
Dim i As Long
Dim fso As Object
Dim folderPath As String
Dim fullPath As String
Dim f As Object
Set wsPrev = ThisWorkbook.Worksheets(SHEET_PREVIEW)
Set fso = CreateObject("Scripting.FileSystemObject")
lastRow = wsPrev.Cells(wsPrev.Rows.Count, 1).End(xlUp).row
For i = 2 To lastRow
If Trim(wsPrev.Cells(i, 1).Value) <> "" Then
' Build full path
If Trim(wsPrev.Cells(i, 3).Value) = "" Then
folderPath = MASTER_ROOT
Else
folderPath = MASTER_ROOT & "\" & wsPrev.Cells(i, 3).Value
End If
fullPath = folderPath & "\" & wsPrev.Cells(i, 1).Value
If fso.FileExists(fullPath) Then
Set f = fso.GetFile(fullPath)
wsPrev.Cells(i, 2).Value = BuildNewFileName(f, wsPrev.Cells(i, 3).Value)
wsPrev.Cells(i, 5).Value = "Pending"
Else
wsPrev.Cells(i, 5).Value = "Missing"
End If
End If
Next i
MsgBox "Preview updated. New names generated.", vbInformation
End Sub
Private Function RemoveExtension(fileName As String) As String
If InStrRev(fileName, ".") > 0 Then
RemoveExtension = Left$(fileName, InStrRev(fileName, ".") - 1)
Else
RemoveExtension = fileName
End If
End Function
' ============================================================
' APPLY RENAMES ENGINE (FINAL VERSION)
' ============================================================
Public Sub ApplyRenames()
If Not MASTER_ROOT_INITIALIZED Then
InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Dim wsPrev As Worksheet
Dim lastRow As Long
Dim i As Long
Dim oldName As String
Dim newName As String
Dim relFolder As String
Dim oldPath As String
Dim newPath As String
Dim fullFolderPath As String
On Error GoTo RenameError
' Ensure MASTER_ROOT is initialized
If Not MASTER_ROOT_INITIALIZED Then
Call InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Set wsPrev = ThisWorkbook.Worksheets(SHEET_PREVIEW)
lastRow = wsPrev.Cells(wsPrev.Rows.Count, 1).End(xlUp).row
If lastRow < 2 Then
MsgBox "Preview Mode is empty. Run Scan first.", vbExclamation
Exit Sub
End If
' --------------------------------------------------------
' LOOP THROUGH PREVIEW ROWS
' --------------------------------------------------------
For i = 2 To lastRow
' Only rename rows marked Pending
If SafeValue(wsPrev.Cells(i, 5).Value) <> "Pending" Then GoTo NextRow
oldName = SafeValue(wsPrev.Cells(i, 1).Value)
newName = SafeValue(wsPrev.Cells(i, 2).Value)
relFolder = SafeValue(wsPrev.Cells(i, 3).Value)
' Build full folder path
If relFolder = "" Then
fullFolderPath = MASTER_ROOT
Else
fullFolderPath = MASTER_ROOT & "\" & relFolder
End If
' Protected folder check
If IsProtectedDevFolder(fullFolderPath) Then
wsPrev.Cells(i, 5).Value = "Skipped (Protected Folder)"
Call LogAction(LOG_SOURCE_MASTER, fullFolderPath, "RENAME SKIPPED", _
"Protected folder: " & PROTECTED_DEV_FOLDER_NAME)
GoTo NextRow
End If
' Build full paths
If relFolder = "" Then
oldPath = MASTER_ROOT & "\" & oldName
newPath = MASTER_ROOT & "\" & newName
Else
oldPath = MASTER_ROOT & "\" & relFolder & "\" & oldName
newPath = MASTER_ROOT & "\" & relFolder & "\" & newName
End If
' Validate paths
If Not FileExists(oldPath) Then
wsPrev.Cells(i, 5).Value = "Missing"
Call LogAction(LOG_SOURCE_MASTER, oldPath, "RENAME SKIPPED", "Original file not found")
GoTo NextRow
End If
If FileExists(newPath) Then
wsPrev.Cells(i, 5).Value = "Conflict"
Call LogAction(LOG_SOURCE_MASTER, newPath, "RENAME SKIPPED", "Target name already exists")
GoTo NextRow
End If
' Attempt rename
If SafeRenameFile(oldPath, newPath) Then
wsPrev.Cells(i, 5).Value = "Renamed"
Call LogAction(LOG_SOURCE_MASTER, newPath, "RENAME SUCCESS", "Renamed from " & oldName)
' Update Master Index
Call UpdateMasterIndex(newPath, relFolder, newName, wsPrev.Cells(i, 4).Value)
Else
wsPrev.Cells(i, 5).Value = "Error"
Call LogAction(LOG_SOURCE_MASTER, oldPath, "RENAME FAILED", "Rename operation failed")
End If
NextRow:
Next i
MsgBox "Renaming complete. Review Preview Mode for results.", vbInformation
Exit Sub
RenameError:
MsgBox "Error applying renames: " & Err.description, vbCritical, "Rename Error"
End Sub
Private Function SafeRenameFile(ByVal oldPath As String, ByVal newPath As String) As Boolean
On Error GoTo RenameFail
Name oldPath As newPath
SafeRenameFile = True
Exit Function
RenameFail:
SafeRenameFile = False
End Function
Private Function FileExists(ByVal filePath As String) As Boolean
On Error Resume Next
FileExists = (Dir(filePath) <> "")
End Function
Private Function SafeValue(v As Variant) As String
If IsError(v) Then
SafeValue = ""
ElseIf IsNull(v) Then
SafeValue = ""
Else
SafeValue = Trim$(CStr(v))
End If
End Function
------------------------------------------------------------
============================================================
FILE: modRibbonCallbacks.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modRibbonCallbacks.txt
============================================================
Option Explicit
Public gRibbon As IRibbonUI
' ============================================================
' RIBBON INITIALIZATION
' ============================================================
Public Sub RibbonOnLoad(ribbon As IRibbonUI)
Set gRibbon = ribbon
End Sub
' ============================================================
' RIBBON CALLBACKS — SCAN & PREVIEW
' ============================================================
Public Sub Ribbon_Scan(control As IRibbonControl)
modScanEngine.ScanAndPreparePreview
End Sub
Public Sub UI_PreviewRenames(control As IRibbonControl)
modRenamePipeline.PreviewRenames
End Sub
' ============================================================
' RIBBON CALLBACKS — APPLY RENAMES
' ============================================================
Public Sub UI_ApplyRenames(control As IRibbonControl)
modRenamePipeline.ApplyRenames
End Sub
' ============================================================
' RIBBON CALLBACKS — SYNC
' ============================================================
Public Sub UI_Sync(control As IRibbonControl)
modSyncEngine.SyncFolder
End Sub
' ============================================================
' RIBBON CALLBACKS — SEARCH & EXPORT
' ============================================================
Public Sub UI_Search(control As IRibbonControl)
modSearchEngine.RunSearchQuery
End Sub
Public Sub UI_ExportSearch(control As IRibbonControl)
modSearchEngine.ExportSearchResults
End Sub
Public Sub UI_ZipExport(control As IRibbonControl)
modSearchEngine.ZipSearchResults
End Sub
Public Sub UI_EmailExport(control As IRibbonControl)
modSearchEngine.EmailSearchResults
End Sub
Public Sub UI_PrintSearch(control As IRibbonControl)
modSearchEngine.PrintSearchResults
End Sub
' ============================================================
' RIBBON CALLBACKS — SYSTEM HEALTH & DIAGNOSTICS
' ============================================================
Public Sub UI_SystemHealth(control As IRibbonControl)
modDiagnosticsEngine.SystemHealthCheck
End Sub
Public Sub UI_IndexIntegrity(control As IRibbonControl)
modDiagnosticsEngine.IndexIntegrityCheck
End Sub
Public Sub UI_FolderConsistency(control As IRibbonControl)
modDiagnosticsEngine.FolderConsistencyCheck
End Sub
Public Sub UI_SystemInfo(control As IRibbonControl)
modDiagnosticsEngine.ShowSystemInfo
End Sub
------------------------------------------------------------
============================================================
FILE: modScanEngine.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modScanEngine.txt
============================================================
Option Explicit
' ============================================================
' SCAN ENGINE
' Scans MASTER_ROOT and populates the Preview sheet
' with: FileName, NewName (blank), Folder, Hash, Status
' ============================================================
Public Sub ScanAndPreparePreview()
If Not MASTER_ROOT_INITIALIZED Then
InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Dim wsPrev As Worksheet
Dim fso As Object
Dim rootFolder As Object
Dim subFolder As Object
Dim fileObj As Object
Dim nextRow As Long
Set wsPrev = ThisWorkbook.Worksheets(SHEET_PREVIEW)
Set fso = CreateObject("Scripting.FileSystemObject")
Set rootFolder = fso.GetFolder(MASTER_ROOT)
' Clear preview sheet except headers
wsPrev.Rows("2:" & wsPrev.Rows.Count).ClearContents
nextRow = 2
' --------------------------------------------------------
' SCAN ROOT FOLDER
' --------------------------------------------------------
For Each fileObj In rootFolder.Files
AddPreviewRow wsPrev, nextRow, fileObj, ""
nextRow = nextRow + 1
Next fileObj
' --------------------------------------------------------
' SCAN SUBFOLDERS
' --------------------------------------------------------
For Each subFolder In rootFolder.SubFolders
If Not IsProtectedDevFolder(subFolder.path) Then
For Each fileObj In subFolder.Files
AddPreviewRow wsPrev, nextRow, fileObj, subFolder.Name
nextRow = nextRow + 1
Next fileObj
End If
Next subFolder
MsgBox "Scan complete. Preview sheet updated.", vbInformation
End Sub
' ============================================================
' ADD A ROW TO PREVIEW SHEET
' ============================================================
Private Sub AddPreviewRow(ws As Worksheet, ByVal rowNum As Long, _
f As Object, relFolder As String)
ws.Cells(rowNum, 1).Value = f.Name ' FileName
ws.Cells(rowNum, 2).Value = "" ' NewName (filled later)
ws.Cells(rowNum, 3).Value = relFolder ' Folder
ws.Cells(rowNum, 4).Value = "" ' Hash (optional)
ws.Cells(rowNum, 5).Value = "Ready" ' Status
End Sub
------------------------------------------------------------
============================================================
FILE: modScannerEngine.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modScannerEngine.txt
============================================================
Option Explicit
' ============================================================
' SCANNER ENGINE (LEGACY STUB)
' All filename/contents extraction has been consolidated into:
' - modSearchEngine.ExtractDescriptionFromFilename
' - modSearchEngine.ExtractTextByExtension
'
' This
=== MODULE SECTION ===
module is intentionally left without public functions
' to avoid ambiguous names and duplicate logic.
' ============================================================
' (Intentionally no Public functions here.)
' If you ever need scanner-specific helpers again,
' add NEW names here that do NOT duplicate anything in:
' - modSearchEngine
' - modFileScanner
------------------------------------------------------------
============================================================
FILE: modSearchEngine.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modSearchEngine.txt
============================================================
Option Explicit
' ============================================================
' DESCRIPTION EXTRACTION FROM FILENAME
' ============================================================
Public Function ExtractDescriptionFromFilename(ByVal fullName As String) As String
Dim baseName As String
Dim parts() As String
Dim i As Long
Dim token As String
Dim result As String
' 1) Strip path and extension
baseName = GetBaseName(fullName)
If Len(Trim$(baseName)) = 0 Then Exit Function
' 2) Normalize separators
baseName = Replace(baseName, "-", " ")
baseName = Replace(baseName, "_", " ")
' 3) Split into tokens
parts = Split(baseName, " ")
For i = LBound(parts) To UBound(parts)
token = Trim$(parts(i))
If Len(token) = 0 Then GoTo NextToken
' Ignore obvious junk / generic words
If IsGenericToken(token) Then GoTo NextToken
' Ignore pure numbers
If IsNumeric(token) Then GoTo NextToken
' Ignore date-like tokens
If LooksLikeDateToken(token) Then GoTo NextToken
' Keep token
If Len(result) > 0 Then
result = result & " " & token
Else
result = token
End If
NextToken:
Next i
ExtractDescriptionFromFilename = Trim$(result)
End Function
Private Function GetBaseName(ByVal fullName As String) As String
Dim f As String
f = fullName
' Strip path
If InStr(f, "\") > 0 Then
f = Mid$(f, InStrRev(f, "\") + 1)
End If
' Strip extension
If InStr(f, ".") > 0 Then
f = Left$(f, InStrRev(f, ".") - 1)
End If
GetBaseName = f
End Function
Private Function IsGenericToken(ByVal token As String) As Boolean
Dim t As String
t = LCase$(token)
If Len(t) <= 2 Then
IsGenericToken = True
Exit Function
End If
Select Case t
Case "test", "file", "document", "doc", "copy", "new", "final", _
"protected", "scan", "scanned", "img", "image", "photo"
IsGenericToken = True
Case Else
IsGenericToken = False
End Select
End Function
Private Function LooksLikeDateToken(ByVal token As String) As Boolean
Dim t As String
t = Replace(Replace(Replace(token, "-", ""), "_", ""), "/", "")
If Len(t) >= 6 And Len(t) <= 8 And IsNumeric(t) Then
LooksLikeDateToken = True
Else
LooksLikeDateToken = False
End If
End Function
' ============================================================
' TEXT EXTRACTION ROUTER
' ============================================================
Public Function ExtractTextByExtension(ByVal filePath As String) As String
Dim ext As String
ext = LCase$(Mid$(filePath, InStrRev(filePath, ".") + 1))
Select Case ext
Case "pdf"
ExtractTextByExtension = ExtractTextFromPDF(filePath)
Case "docx"
ExtractTextByExtension = ExtractTextFromDocx(filePath)
Case "txt"
ExtractTextByExtension = ExtractTextFromTxt(filePath)
Case "xls", "xlsx", "xlsm"
ExtractTextByExtension = ExtractExcelText_V2(filePath)
Case Else
ExtractTextByExtension = ""
End Select
End Function
' ============================================================
' PDF TEXT EXTRACTION (via pdftotext.exe)
' ============================================================
Public Function ExtractTextFromPDF(ByVal pdfPath As String) As String
Dim tempTxt As String
Dim cmd As String
Dim f As Integer
Dim content As String
tempTxt = Environ$("TEMP") & "\pdf_extract_" & Format(Now, "yyyymmdd_hhnnss") & ".txt"
cmd = """" & PDFTOTEXT & """ -layout """ & pdfPath & """ """ & tempTxt & """"
shell cmd, vbHide
Application.Wait Now + TimeValue("0:00:01")
If Dir(tempTxt) <> "" Then
f = FreeFile
Open tempTxt For Input As #f
content = Input$(LOF(f), f)
Close #f
End If
ExtractTextFromPDF = content
End Function
' ============================================================
' DOCX TEXT EXTRACTION (via 7z.exe)
' ============================================================
Public Function ExtractTextFromDocx(ByVal docxPath As String) As String
Dim tempFolder As String
Dim xmlPath As String
Dim cmd As String
Dim xmlContent As String
Dim cleaned As String
Dim f As Integer
tempFolder = Environ$("TEMP") & "\docx_extract_" & Format(Now, "yyyymmdd_hhnnss")
MkDir tempFolder
cmd = """" & TOOLS_ROOT & "docx2txt\7z.exe"" x """ & docxPath & """ -o""" & tempFolder & """ -y"
shell cmd, vbHide
Application.Wait Now + TimeValue("0:00:01")
xmlPath = tempFolder & "\word\document.xml"
If Dir(xmlPath) = "" Then
ExtractTextFromDocx = ""
Exit Function
End If
f = FreeFile
Open xmlPath For Input As #f
xmlContent = Input$(LOF(f), f)
Close #f
cleaned = Replace(xmlContent, "<w:t>", "")
cleaned = Replace(cleaned, "</w:t>", vbCrLf)
ExtractTextFromDocx = cleaned
End Function
' ============================================================
' TXT TEXT EXTRACTION
' ============================================================
Public Function ExtractTextFromTxt(filePath As String) As String
Dim f As Integer
Dim content As String
On Error GoTo Fail
f = FreeFile
Open filePath For Input As #f
content = Input$(LOF(f), f)
Close #f
ExtractTextFromTxt = content
Exit Function
Fail:
On Error Resume Next
If f > 0 Then Close #f
ExtractTextFromTxt = ""
End Function
' ============================================================
' XLSX TEXT EXTRACTION (V2)
' ============================================================
Public Function ExtractExcelText_V2(filePath As String) As String
Dim xlApp As Object
Dim xlBook As Object
Dim ws As Object
Dim r As Range
Dim textOut As String
Dim sheetHeader As String
On Error GoTo CleanFail
Set xlApp = CreateObject("Excel.Application")
xlApp.DisplayAlerts = False
xlApp.visible = False
Set xlBook = xlApp.Workbooks.Open(filePath, False, True)
For Each ws In xlBook.Worksheets
sheetHeader = vbCrLf & "=== Sheet: " & ws.Name & " ===" & vbCrLf
textOut = textOut & sheetHeader
If Not ws.UsedRange Is Nothing Then
For Each r In ws.UsedRange.Cells
If Len(Trim$(r.Text)) > 0 Then
textOut = textOut & r.Text & vbCrLf
End If
Next r
End If
Next ws
CleanExit:
On Error Resume Next
If Not xlBook Is Nothing Then xlBook.Close False
If Not xlApp Is Nothing Then xlApp.Quit
Set xlBook = Nothing
Set xlApp = Nothing
ExtractExcelText_V2 = textOut
Exit Function
CleanFail:
Resume CleanExit
End Function
' ============================================================
' TEXT LOADER FROM STORAGE (by hash)
' ============================================================
Private Function LoadExtractedText(ByVal hashVal As String) As String
Dim textPath As String
Dim f As Integer
Dim content As String
On Error GoTo Fail
textPath = TEXT_STORAGE_ROOT & "\" & hashVal & ".txt"
If Len(Dir(textPath)) = 0 Then
LoadExtractedText = ""
Exit Function
End If
f = FreeFile
Open textPath For Input As #f
content = Input$(LOF(f), f)
Close #f
LoadExtractedText = content
Exit Function
Fail:
On Error Resume Next
If f > 0 Then Close #f
LoadExtractedText = ""
End Function
' ============================================================
' SEARCH PIPELINE
' ============================================================
Private Sub SearchPipeline(ByVal query As String, ByRef ws As Worksheet)
Dim nextRow As Long
nextRow = 5
' 1) Filename + folder search
Call Search_FilenamesAndFolders(query, ws, nextRow)
' 2) Extracted text search
Call Search_ExtractedText(query, ws, nextRow)
' 3) OCR search
Call Search_OCRText(query, ws, nextRow)
' 4) XLSX search
Call Search_XLSXText(query, ws, nextRow)
' 5) Deduplicate
Call RemoveDuplicateResults(ws)
' 6) Sort by score
Call RankAndSortResults(ws)
End Sub
' ============================================================
' PLACEHOLDER EXPORT STUBS
' ============================================================
Public Sub ZipSearchResults()
MsgBox "Zip export not implemented yet."
End Sub
Public Sub EmailSearchResults()
MsgBox "Email export not implemented yet."
End Sub
' ============================================================
' SEARCH LAYER: FILENAMES + FOLDERS
' ============================================================
Private Sub Search_FilenamesAndFolders(ByVal query As String, ByRef ws As Worksheet, ByRef nextRow As Long)
Dim wsPrev As Worksheet
Dim lastRow As Long
Dim i As Long
Dim fileName As String
Dim folder As String
Dim hashVal As String
Dim score As Long
Dim preview As String
Set wsPrev = ThisWorkbook.Worksheets(SHEET_PREVIEW)
lastRow = wsPrev.Cells(wsPrev.Rows.Count, 1).End(xlUp).row
For i = 2 To lastRow
fileName = wsPrev.Cells(i, 1).Value
folder = wsPrev.Cells(i, 3).Value
hashVal = wsPrev.Cells(i, 4).Value
score = 0
If InStr(1, fileName, query, vbTextCompare) > 0 Then
score = score + 50
End If
If InStr(1, folder, query, vbTextCompare) > 0 Then
score = score + 20
End If
If score > 0 Then
preview = Left(fileName, 50)
WriteResultRow ws, nextRow, fileName, folder, hashVal, score, preview, query
End If
Next i
End Sub
' ============================================================
' SEARCH LAYER: EXTRACTED TEXT
' ============================================================
Private Sub Search_ExtractedText(ByVal query As String, ByRef ws As Worksheet, ByRef nextRow As Long)
Dim wsPrev As Worksheet
Dim lastRow As Long
Dim i As Long
Dim fileName As String
Dim folder As String
Dim hashVal As String
Dim textContent As String
Dim score As Long
Dim preview As String
Set wsPrev = ThisWorkbook.Worksheets(SHEET_PREVIEW)
lastRow = wsPrev.Cells(wsPrev.Rows.Count, 1).End(xlUp).row
For i = 2 To lastRow
fileName = wsPrev.Cells(i, 1).Value
folder = wsPrev.Cells(i, 3).Value
hashVal = wsPrev.Cells(i, 4).Value
textContent = LoadExtractedText(hashVal)
If Len(textContent) = 0 Then GoTo NextFile
score = 0
If InStr(1, textContent, query, vbTextCompare) > 0 Then
score = score + 100
End If
If score > 0 Then
preview = BuildSnippet(textContent, query)
WriteResultRow ws, nextRow, fileName, folder, hashVal, score, preview, query
End If
NextFile:
Next i
End Sub
' ============================================================
' SEARCH LAYER: OCR TEXT
' ============================================================
Private Sub Search_OCRText(ByVal query As String, ByRef ws As Worksheet, ByRef nextRow As Long)
Dim wsPrev As Worksheet
Dim lastRow As Long
Dim i As Long
Dim fileName As String
Dim folder As String
Dim hashVal As String
Dim textContent As String
Dim score As Long
Dim preview As String
Set wsPrev = ThisWorkbook.Worksheets(SHEET_PREVIEW)
lastRow = wsPrev.Cells(wsPrev.Rows.Count, 1).End(xlUp).row
For i = 2 To lastRow
fileName = wsPrev.Cells(i, 1).Value
folder = wsPrev.Cells(i, 3).Value
hashVal = wsPrev.Cells(i, 4).Value
textContent = LoadExtractedText(hashVal)
If Len(textContent) = 0 Then GoTo NextFile
score = 0
If InStr(1, textContent, query, vbTextCompare) > 0 Then
score = score + 80
End If
If score > 0 Then
preview = BuildSnippet(textContent, query)
WriteResultRow ws, nextRow, fileName, folder, hashVal, score, preview, query
End If
NextFile:
Next i
End Sub
' ============================================================
' SEARCH LAYER: XLSX TEXT
' ============================================================
Private Sub Search_XLSXText(ByVal query As String, ByRef ws As Worksheet, ByRef nextRow As Long)
Dim wsPrev As Worksheet
Dim lastRow As Long
Dim i As Long
Dim fileName As String
Dim folder As String
Dim hashVal As String
Dim textContent As String
Dim score As Long
Dim preview As String
Set wsPrev = ThisWorkbook.Worksheets(SHEET_PREVIEW)
lastRow = wsPrev.Cells(wsPrev.Rows.Count, 1).End(xlUp).row
For i = 2 To lastRow
fileName = wsPrev.Cells(i, 1).Value
folder = wsPrev.Cells(i, 3).Value
hashVal = wsPrev.Cells(i, 4).Value
textContent = LoadExtractedText(hashVal)
If Len(textContent) = 0 Then GoTo NextFile
score = 0
If InStr(1, textContent, query, vbTextCompare) > 0 Then
score = score + 60
End If
If score > 0 Then
preview = BuildSnippet(textContent, query)
WriteResultRow ws, nextRow, fileName, folder, hashVal, score, preview, query
End If
NextFile:
Next i
End Sub
' ============================================================
' SNIPPET BUILDER
' ============================================================
Private Function BuildSnippet(ByVal textContent As String, ByVal query As String) As String
Dim pos As Long
Dim startPos As Long
Dim endPos As Long
Dim snippet As String
pos = InStr(1, textContent, query, vbTextCompare)
If pos = 0 Then
BuildSnippet = Left(textContent, 200)
Exit Function
End If
startPos = Application.Max(1, pos - 60)
endPos = Application.Min(Len(textContent), pos + Len(query) + 60)
snippet = Mid(textContent, startPos, endPos - startPos + 1)
If startPos > 1 Then snippet = "..." & snippet
If endPos < Len(textContent) Then snippet = snippet & "..."
BuildSnippet = snippet
End Function
' ============================================================
' HIGHLIGHT MATCHED TERM IN SNIPPET
' ============================================================
Private Sub HighlightMatch(c As Range, ByVal query As String)
Dim pos As Long
pos = InStr(1, c.Value, query, vbTextCompare)
If pos > 0 Then
With c.Characters(pos, Len(query)).Font
.Color = RGB(200, 0, 0)
.Bold = True
End With
End If
End Sub
' ============================================================
' CENTRALIZED RESULT ROW WRITER
' ============================================================
Private Sub WriteResultRow(ws As Worksheet, ByRef nextRow As Long, _
ByVal fileName As String, ByVal folder As String, _
ByVal hashVal As String, ByVal score As Long, _
ByVal preview As String, ByVal query As String)
ws.Cells(nextRow, 1).Value = fileName
ws.Cells(nextRow, 2).Value = folder
ws.Cells(nextRow, 3).Value = hashVal
ws.Cells(nextRow, 4).Value = score
ws.Cells(nextRow, 5).Value = preview
HighlightMatch ws.Cells(nextRow, 5), query
nextRow = nextRow + 1
End Sub
' ============================================================
' REMOVE DUPLICATE RESULTS (by hash)
' ============================================================
Private Sub RemoveDuplicateResults(ByRef ws As Worksheet)
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
If lastRow < 5 Then Exit Sub
ws.Range("A4:E" & lastRow).RemoveDuplicates Columns:=3, Header:=xlYes
End Sub
' ============================================================
' RANK AND SORT RESULTS (by score desc)
' ============================================================
Private Sub RankAndSortResults(ByRef ws As Worksheet)
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
If lastRow < 5 Then Exit Sub
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add key:=ws.Range("D5:D" & lastRow), _
SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ws.Sort
.SetRange ws.Range("A4:E" & lastRow)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
End Sub
' ============================================================
' RUN SEARCH ENTRY POINT
' ============================================================
Public Sub RunSearchQuery()
Dim query As String
Dim ws As Worksheet
Dim lastRow As Long
Dim fc As FormatCondition
Set ws = ThisWorkbook.Worksheets("SearchResults")
' Clear old results
ws.Range("A5:E100000").ClearContents
' Read query
query = Trim$(ws.Range("G1").Value)
query = LCase$(query)
If Len(query) = 0 Then
MsgBox "Enter a search term in cell G1.", vbExclamation
Exit Sub
End If
' Ensure headers
ws.Range("A4:E4").Value = Array("File Name", "Folder", "Hash", "Score", "Snippet")
' Run pipeline
Call SearchPipeline(query, ws)
Call ApplyRefineFilter(ws.Range("I1").Value, ws)
' Auto-fit columns
ws.Columns("A:E").AutoFit
' Zebra striping
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
If lastRow < 5 Then Exit Sub
ws.Range("A3:E" & lastRow).FormatConditions.Delete
Set fc = ws.Range("A3:E" & lastRow).FormatConditions.Add(Type:=xlExpression, Formula1:="=MOD(ROW(),2)=1")
fc.Interior.Color = RGB(245, 245, 245)
End Sub
' ============================================================
' FILE ACTIONS
' ============================================================
Public Sub OpenSelectedFile()
Dim ws As Worksheet
Dim filePath As String
Dim row As Long
Set ws = ThisWorkbook.Worksheets("SearchResults")
row = ActiveCell.row
If row < 5 Then Exit Sub
filePath = ws.Cells(row, 2).Value & "\" & ws.Cells(row, 1).Value
If Len(Dir(filePath)) = 0 Then
MsgBox "File not found:" & vbCrLf & filePath, vbExclamation
Exit Sub
End If
shell "explorer.exe """ & filePath & """", vbNormalFocus
End Sub
Public Sub OpenFileLocation()
Dim ws As Worksheet
Dim row As Long
Dim folderPath As String
Set ws = ThisWorkbook.Worksheets("SearchResults")
row = ActiveCell.row
If row < 5 Then Exit Sub
folderPath = ws.Cells(row, 2).Value
If Len(Dir(folderPath, vbDirectory)) = 0 Then
MsgBox "Folder not found:" & vbCrLf & folderPath, vbExclamation
Exit Sub
End If
shell "explorer.exe """ & folderPath & """", vbNormalFocus
End Sub
Public Sub CopyFullPath()
Dim ws As Worksheet
Dim row As Long
Dim fullPath As String
Dim DataObj As Object
Set ws = ThisWorkbook.Worksheets("SearchResults")
row = ActiveCell.row
If row < 5 Then Exit Sub
fullPath = ws.Cells(row, 2).Value & "\" & ws.Cells(row, 1).Value
Set DataObj = CreateObject("MSForms.DataObject")
DataObj.SetText fullPath
DataObj.PutInClipboard
MsgBox "Copied:" & vbCrLf & fullPath, vbInformation
End Sub
' ============================================================
' TOOLTIP SUPPORT
' ============================================================
Public Sub ShowTooltip(ByVal row As Long)
Dim ws As Worksheet
Dim fileName As String, folderPath As String, snippet As String, score As String
Dim tip As String
Set ws = ThisWorkbook.Worksheets("SearchResults")
If row < 5 Then Exit Sub
fileName = ws.Cells(row, 1).Value
folderPath = ws.Cells(row, 2).Value
score = ws.Cells(row, 4).Value
snippet = ws.Cells(row, 5).Value
tip = "File: " & fileName & vbCrLf & _
"Folder: " & folderPath & vbCrLf & _
"Score: " & score & vbCrLf & _
"Snippet: " & snippet
Application.StatusBar = tip
End Sub
Public Sub ClearTooltip()
Application.StatusBar = False
End Sub
' ============================================================
' SORT RESULTS (header double-click)
' ============================================================
Public Sub SortResults(ByVal col As Long)
Dim ws As Worksheet
Dim lastRow As Long
Set ws = ThisWorkbook.Worksheets("SearchResults")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
If lastRow < 5 Then Exit Sub
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add key:=ws.Range(ws.Cells(5, col), ws.Cells(lastRow, col)), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ws.Sort
.SetRange ws.Range("A5:E" & lastRow)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.Apply
End With
End Sub
' ============================================================
' REFINE RESULTS (search within results)
' ============================================================
Public Sub RefineResults(ByVal refineTerm As String)
Dim ws As Worksheet
Dim lastRow As Long
Dim r As Long
Dim rowVisible As Boolean
Set ws = ThisWorkbook.Worksheets("SearchResults")
refineTerm = LCase$(Trim$(refineTerm))
If Len(refineTerm) = 0 Then Exit Sub
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
For r = 5 To lastRow
rowVisible = False
If InStr(1, LCase$(ws.Cells(r, 1).Value), refineTerm) > 0 Then rowVisible = True
If InStr(1, LCase$(ws.Cells(r, 2).Value), refineTerm) > 0 Then rowVisible = True
If InStr(1, LCase$(ws.Cells(r, 3).Value), refineTerm) > 0 Then rowVisible = True
If InStr(1, LCase$(ws.Cells(r, 4).Value), refineTerm) > 0 Then rowVisible = True
If InStr(1, LCase$(ws.Cells(r, 5).Value), refineTerm) > 0 Then rowVisible = True
ws.Rows(r).EntireRow.Hidden = Not rowVisible
Next r
End Sub
Public Sub PromptRefine()
Dim refineTerm As String
refineTerm = InputBox("Enter refine term:", "Refine Results")
If Len(refineTerm) > 0 Then
Call RefineResults(refineTerm)
End If
End Sub
Private Sub ApplyRefineFilter(ByVal refineTerm As String, ByRef ws As Worksheet)
Dim lastRow As Long
Dim r As Long
Dim visible As Boolean
refineTerm = LCase$(Trim$(refineTerm))
If Len(refineTerm) = 0 Then Exit Sub
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
For r = 5 To lastRow
visible = False
If InStr(1, LCase$(ws.Cells(r, 1).Value), refineTerm) > 0 Then visible = True
If InStr(1, LCase$(ws.Cells(r, 2).Value), refineTerm) > 0 Then visible = True
If InStr(1, LCase$(ws.Cells(r, 3).Value), refineTerm) > 0 Then visible = True
If InStr(1, LCase$(ws.Cells(r, 4).Value), refineTerm) > 0 Then visible = True
If InStr(1, LCase$(ws.Cells(r, 5).Value), refineTerm) > 0 Then visible = True
ws.Rows(r).EntireRow.Hidden = Not visible
Next r
End Sub
Public Function ExtractMetadata(filePath As String) As Object
Dim shell As Object
Dim folder As Object
Dim file As Object
Dim dict As Object
Dim i As Long
Set dict = CreateObject("Scripting.Dictionary")
Set shell = CreateObject("Shell.Application")
Set folder = shell.Namespace(GetFolderFromPath(filePath))
If folder Is Nothing Then
Set ExtractMetadata = dict
Exit Function
End If
Set file = folder.ParseName(GetFileNameFromPath(filePath))
If file Is Nothing Then
Set ExtractMetadata = dict
Exit Function
End If
' Loop through metadata columns
For i = 0 To 300
On Error Resume Next
Dim key As String
Dim val As String
key = folder.GetDetailsOf(folder.Items, i)
val = folder.GetDetailsOf(file, i)
If Len(key) > 0 And Len(val) > 0 Then
dict(key) = val
End If
Next i
Set ExtractMetadata = dict
End Function
' ============================================================
' PATH UTILITIES
' ============================================================
' Returns the folder portion of a full path
Private Function GetFolderFromPath(path As String) As String
If InStrRev(path, "\") > 1 Then
GetFolderFromPath = Left$(path, InStrRev(path, "\") - 1)
Else
GetFolderFromPath = ""
End If
End Function
' Returns only the filename.ext portion of a full path
Private Function GetFileNameFromPath(path As String) As String
GetFileNameFromPath = Mid$(path, InStrRev(path, "\") + 1)
End Function
' Returns the parent folder of a full path
Private Function GetParentFolder(path As String) As String
GetParentFolder = GetFolderFromPath(path)
End Function
' ============================================================
' EXPORT SEARCH RESULTS
' ============================================================
Public Sub ExportSearchResults()
Dim wsResults As Worksheet
Dim lastRow As Long
Dim i As Long
Dim filePaths As New Collection
Dim fullPath As String
Dim folderPath As String
Dim fileName As String
Dim parentFolder As String
' Ensure MASTER_ROOT is initialized
If Not MASTER_ROOT_INITIALIZED Then
InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Set wsResults = ThisWorkbook.Worksheets(SHEET_SEARCH_RESULTS)
' Determine last row with results
lastRow = wsResults.Cells(wsResults.Rows.Count, 1).End(xlUp).row
If lastRow < 5 Then
MsgBox "Search Results is empty. Run a search first.", vbExclamation
Exit Sub
End If
' ------------------------------------------------------------
' COLLECT FILE PATHS FROM SEARCH RESULTS
' ------------------------------------------------------------
For i = 5 To lastRow
fileName = SafeValue(wsResults.Cells(i, 1).Value) ' FileName
folderPath = SafeValue(wsResults.Cells(i, 2).Value) ' FolderPath
If fileName <> "" And folderPath <> "" Then
' Build full path
fullPath = folderPath & "\" & fileName
' Determine parent folder for protection check
parentFolder = GetParentFolder(fullPath)
' Skip protected dev folder
If IsProtectedDevFolder(parentFolder) Then
LogAction LOG_SOURCE_MASTER, fullPath, "EXPORT SKIPPED", _
"Protected folder: " & PROTECTED_DEV_FOLDER_NAME
Else
filePaths.Add fullPath
End If
End If
Next i
' ------------------------------------------------------------
' PERFORM EXPORT
' ------------------------------------------------------------
ExportFileList filePaths, "SearchExport_" & Format(Now, "yyyymmdd_hhnnss")
End Sub
' ============================================================
' PRINT SEARCH RESULTS
' ============================================================
Public Sub PrintSearchResults()
Dim ws As Worksheet
Dim lastRow As Long
' Ensure MASTER_ROOT is initialized
If Not MASTER_ROOT_INITIALIZED Then
InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Set ws = ThisWorkbook.Worksheets(SHEET_SEARCH_RESULTS)
' Determine last row with results
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
If lastRow < 5 Then
MsgBox "Search Results is empty. Run a search first.", vbExclamation
Exit Sub
End If
' ------------------------------------------------------------
' SET PRINT AREA
' ------------------------------------------------------------
ws.PageSetup.PrintArea = "$A$1:$E$" & lastRow
' Landscape for readability
ws.PageSetup.Orientation = xlLandscape
' Fit to one page wide
ws.PageSetup.Zoom = False
ws.PageSetup.FitToPagesWide = 1
ws.PageSetup.FitToPagesTall = False
' ------------------------------------------------------------
' ------------------------------------------------------------
ws.PrintOut
MsgBox "Search Results sent to printer.", vbInformation
End Sub
------------------------------------------------------------
============================================================
FILE: modSearchResults.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modSearchResults.txt
============================================================
Option Explicit
' ============================================================
' DOUBLE-CLICK HANDLER (open file OR sort)
' ============================================================
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' 1. Double-click on results ? open file
If Target.Column >= 1 And Target.Column <= 5 And Target.row >= 5 Then
Cancel = True
Call OpenSelectedFile
Exit Sub
End If
' 2. Double-click on headers ? sort by column
If Target.row = 4 And Target.Column >= 1 And Target.Column <= 5 Then
Cancel = True
Call SortResults(Target.Column)
Exit Sub
End If
End Sub
' ============================================================
' RIGHT-CLICK CONTEXT MENU
' ============================================================
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
' Only show menu inside results grid (A–E, row 5+)
If Target.Column < 1 Or Target.Column > 5 Or Target.row < 5 Then Exit Sub
Cancel = True
Dim cbar As CommandBar
Dim ctrl As CommandBarControl
' Delete old temporary bar if it exists
On Error Resume Next
Application.CommandBars("SearchMenu").Delete
On Error GoTo 0
' Create new popup menu
Set cbar = Application.CommandBars.Add(Name:="SearchMenu", Position:=msoBarPopup, Temporary:=True)
' Add "Open File"
Set ctrl = cbar.Controls.Add(Type:=msoControlButton)
ctrl.Caption = "Open File"
ctrl.OnAction = "OpenSelectedFile"
' Add "Open File Location"
Set ctrl = cbar.Controls.Add(Type:=msoControlButton)
ctrl.Caption = "Open File Location"
ctrl.OnAction = "OpenFileLocation"
' Add "Copy Full Path"
Set ctrl = cbar.Controls.Add(Type:=msoControlButton)
ctrl.Caption = "Copy Full Path"
ctrl.OnAction = "CopyFullPath"
' Add "Refine Results"
Set ctrl = cbar.Controls.Add(Type:=msoControlButton)
ctrl.Caption = "Refine Results"
ctrl.OnAction = "PromptRefine"
' Show menu
cbar.ShowPopup
End Sub
' ============================================================
' HOVER TOOLTIP
' ============================================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column >= 1 And Target.Column <= 5 And Target.row >= 5 Then
Call ShowTooltip(Target.row)
Else
Call ClearTooltip
End If
End Sub
------------------------------------------------------------
============================================================
FILE: modSettingsEngine.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modSettingsEngine.txt
============================================================
Option Explicit
' ============================================================
' SETTINGS ENGINE
' Reads and validates settings from the Settings sheet.
' Provides system-wide access to configuration values.
' ============================================================
Private settingsLoaded As Boolean
Private dictSettings As Object
' ------------------------------------------------------------
' 1. Load settings into memory
' ------------------------------------------------------------
Public Sub LoadSettings()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim key As String, val As String
On Error GoTo SettingsError
Set ws = ThisWorkbook.Worksheets(SHEET_SETTINGS)
Set dictSettings = CreateObject("Scripting.Dictionary")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
' Read key/value pairs
For i = 2 To lastRow
key = Trim$(SafeValue(ws.Cells(i, 1).Value))
val = Trim$(SafeValue(ws.Cells(i, 2).Value))
If key <> "" Then
dictSettings(key) = val
End If
Next i
settingsLoaded = True
Exit Sub
SettingsError:
MsgBox "Error loading settings: " & Err.description, vbCritical, "Settings Error"
End Sub
' ------------------------------------------------------------
' 2. Get a setting value by key
' ------------------------------------------------------------
Public Function GetSettingValue(ByVal key As String) As String
If Not settingsLoaded Then LoadSettings
If dictSettings.Exists(key) Then
GetSettingValue = dictSettings(key)
Else
GetSettingValue = ""
End If
End Function
' ------------------------------------------------------------
' 3. Validate required settings
' ------------------------------------------------------------
Public Function ValidateSettings() As Boolean
Dim missing As String
missing = ""
' Required settings
If GetSettingValue("MasterRoot") = "" Then missing = missing & "- MasterRoot" & vbCrLf
If GetSettingValue("EnableLogging") = "" Then missing = missing & "- EnableLogging" & vbCrLf
If GetSettingValue("EnablePreview") = "" Then missing = missing & "- EnablePreview" & vbCrLf
If missing <> "" Then
MsgBox "The following required settings are missing:" & vbCrLf & vbCrLf & missing, _
vbCritical, "Settings Validation Failed"
ValidateSettings = False
Else
ValidateSettings = True
End If
End Function
' ------------------------------------------------------------
' 4. Reload settings (manual refresh)
' ------------------------------------------------------------
Public Sub ReloadSettings()
settingsLoaded = False
Call LoadSettings
MsgBox "Settings reloaded.", vbInformation
End Sub
------------------------------------------------------------
============================================================
FILE: modSyncEngine.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modSyncEngine.txt
============================================================
Option Explicit
' ============================================================
' SYNC ENGINE
' Compares MASTER_ROOT with the Master Index and updates:
' - Missing files
' - New files
' - Existing files
' - Status fields
' ============================================================
Public Sub SyncFolder()
' Ensure MASTER_ROOT is initialized
If Not MASTER_ROOT_INITIALIZED Then
InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Dim wsIndex As Worksheet
Dim fso As Object
Dim rootFolder As Object
Dim subFolder As Object
Dim fileObj As Object
Dim fullPath As String
Dim rowNum As Long
Set wsIndex = ThisWorkbook.Worksheets(SHEET_INDEX)
Set fso = CreateObject("Scripting.FileSystemObject")
Set rootFolder = fso.GetFolder(MASTER_ROOT)
' --------------------------------------------------------
' 1. MARK MISSING FILES
' --------------------------------------------------------
For rowNum = 2 To wsIndex.Cells(wsIndex.Rows.Count, COL_FILEPATH).End(xlUp).row
fullPath = SafeValue(wsIndex.Cells(rowNum, COL_FILEPATH).Value)
If fullPath <> "" Then
If Not fso.FileExists(fullPath) Then
wsIndex.Cells(rowNum, COL_STATUS).Value = "Missing"
Else
wsIndex.Cells(rowNum, COL_STATUS).Value = "OK"
End If
End If
Next rowNum
' --------------------------------------------------------
' 2. SCAN ROOT FOLDER FOR NEW FILES
' --------------------------------------------------------
For Each fileObj In rootFolder.Files
HandleSyncFile wsIndex, fileObj
Next fileObj
' --------------------------------------------------------
' 3. SCAN SUBFOLDERS FOR NEW FILES
' --------------------------------------------------------
For Each subFolder In rootFolder.SubFolders
If Not IsProtectedDevFolder(subFolder.path) Then
For Each fileObj In subFolder.Files
HandleSyncFile wsIndex, fileObj
Next fileObj
End If
Next subFolder
MsgBox "Folder sync complete.", vbInformation
End Sub
' ------------------------------------------------------------
' HANDLE A SINGLE FILE DURING SYNC
' ------------------------------------------------------------
Private Sub HandleSyncFile(ByRef ws As Worksheet, ByVal f As Object)
Dim fullPath As String
Dim fileName As String
Dim rowNum As Long
Dim hashVal As String
fullPath = f.path
fileName = f.Name
' Hashing can be added later
hashVal = ""
' Check if file already exists in index
rowNum = FindIndexRowByPath(ws, fullPath)
If rowNum = 0 Then
' NEW FILE ? INSERT
InsertNewIndexRow ws, fullPath, fileName, hashVal
Else
' EXISTING FILE ? UPDATE
UpdateExistingIndexRow ws, rowNum, fullPath, fileName, hashVal
End If
End Sub
' ============================================================
' FIND INDEX ROW BY FULL PATH
' ============================================================
Private Function FindIndexRowByPath(ws As Worksheet, fullPath As String) As Long
Dim lastRow As Long
Dim i As Long
lastRow = ws.Cells(ws.Rows.Count, COL_FILEPATH).End(xlUp).row
For i = 2 To lastRow
If SafeValue(ws.Cells(i, COL_FILEPATH).Value) = fullPath Then
FindIndexRowByPath = i
Exit Function
End If
Next i
FindIndexRowByPath = 0
End Function
------------------------------------------------------------
============================================================
FILE: modUI.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modUI.txt
============================================================
Option Explicit
Private g_Ribbon As IRibbonUI
' ============================================================
' RIBBON HOST
=== MODULE SECTION ===
MODULE
' Only responsible for holding the IRibbonUI reference and
' handling RibbonOnLoad. All actual callbacks live in:
' - modRibbonCallbacks
' - modUIEngine (button handlers)
' ============================================================
' Fires when the Ribbon loads
Public Sub RibbonOnLoad(ribbon As IRibbonUI)
Set g_Ribbon = ribbon
' Optional: comment out the message once you're happy
' MsgBox "Ribbon loaded successfully!", vbInformation, "Ribbon"
End Sub
------------------------------------------------------------
============================================================
FILE: modUIEngine.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modUIEngine.txt
============================================================
Option Explicit
' ============================================================
' UI ENGINE
' ============================================================
Public Sub UIStatus(ByVal msg As String)
Application.StatusBar = msg
End Sub
Public Sub UIClearStatus()
Application.StatusBar = False
End Sub
Public Sub UI_Scan()
UIStatus "Scanning folders..."
ScanAndPreparePreview
UIClearStatus
End Sub
Public Sub UI_ApplyRenames()
UIStatus "Applying renames..."
ApplyRenames
UIClearStatus
End Sub
Public Sub UI_Sync()
UIStatus "Synchronizing folder..."
SyncFolder
UIClearStatus
End Sub
Public Sub UI_ExportSearch()
ExportSearchResults
End Sub
Public Sub UI_ZipExport()
Dim exportName As String
exportName = InputBox("Enter export folder name:", "ZIP Export")
If Trim$(exportName) <> "" Then ZipExport exportName
End Sub
Public Sub UI_EmailExport()
Dim exportName As String
Dim recipient As String
exportName = InputBox("Enter export folder name:", "Email Export")
If Trim$(exportName) = "" Then Exit Sub
recipient = InputBox("Enter recipient email:", "Email Export")
If Trim$(recipient) = "" Then Exit Sub
EmailExport exportName, recipient
End Sub
Public Sub UI_PrintSearch()
PrintSearchResults
End Sub
Public Sub UI_ExportCase(control As IRibbonControl)
Dim caseID As String
caseID = InputBox("Enter Case ID:", "Export Case")
If Trim$(caseID) <> "" Then ExportCase caseID
End Sub
Public Sub UI_EmailCase(control As IRibbonControl)
Dim caseID As String
Dim recipient As String
caseID = InputBox("Enter Case ID:", "Email Case")
If Trim$(caseID) = "" Then Exit Sub
recipient = InputBox("Enter recipient email:", "Email Case")
If Trim$(recipient) = "" Then Exit Sub
EmailCase caseID, recipient
End Sub
Public Sub UI_PrintCase(control As IRibbonControl)
Dim caseID As String
caseID = InputBox("Enter Case ID:", "Print Case")
If Trim$(caseID) <> "" Then PrintCase caseID
End Sub
Public Sub UI_DetectDuplicates()
DetectDuplicates
End Sub
Public Sub UI_MissingMetadata()
DetectMissingMetadata
End Sub
Public Sub UI_ReloadSettings()
ReloadSettings
End Sub
Public Sub UI_IndexIntegrity()
IndexIntegrityCheck
End Sub
Public Sub UI_FolderConsistency()
FolderConsistencyCheck
End Sub
Public Sub UI_SystemInfo()
ShowSystemInfo
End Sub
Public Sub UI_PreviewRenames(control As IRibbonControl)
PreviewRenames
End Sub
------------------------------------------------------------
============================================================
FILE: modUtilities.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modUtilities.txt
============================================================
Option Explicit
' ============================================================
' UTILITIES
=== MODULE SECTION ===
MODULE
' Shared helper functions used across the entire system.
' ============================================================
' ------------------------------------------------------------
' 1. Get file extension (lowercase, no dot)
' ------------------------------------------------------------
Public Function GetFileExtension(ByVal fileName As String) As String
On Error GoTo ExtError
If InStrRev(fileName, ".") > 0 Then
GetFileExtension = LCase$(Mid$(fileName, InStrRev(fileName, ".") + 1))
Else
GetFileExtension = ""
End If
Exit Function
ExtError:
GetFileExtension = ""
End Function
' ------------------------------------------------------------
' 2. Get file type category (PDF, Word, Excel, Image, Video, etc.)
' ------------------------------------------------------------
Public Function GetFileTypeCategory(ByVal fileName As String) As String
Dim ext As String
ext = GetFileExtension(fileName)
Select Case ext
Case "pdf": GetFileTypeCategory = "PDF"
Case "doc", "docx": GetFileTypeCategory = "Word"
Case "xls", "xlsx": GetFileTypeCategory = "Excel"
Case "ppt", "pptx": GetFileTypeCategory = "PowerPoint"
Case "jpg", "jpeg", "png", "gif", "bmp", "tif", "tiff": GetFileTypeCategory = "Image"
Case "mp4", "mov", "avi", "wmv", "mkv": GetFileTypeCategory = "Video"
Case "txt": GetFileTypeCategory = "Text"
Case Else: GetFileTypeCategory = UCase$(ext)
End Select
End Function
' ------------------------------------------------------------
' 3. Extract description from filename + folder
' ------------------------------------------------------------
Public Function ExtractDescription(ByVal hashVal As String) As String
Dim textContent As String
Dim lines As Variant
Dim i As Long
textContent = LoadExtractedText(hashVal)
If Len(textContent) = 0 Then
ExtractDescription = ""
Exit Function
End If
lines = Split(textContent, vbCrLf)
For i = LBound(lines) To UBound(lines)
If Trim$(lines(i)) <> "" Then
ExtractDescription = Trim$(lines(i))
Exit Function
End If
Next i
ExtractDescription = ""
End Function
' ------------------------------------------------------------
' 4. Normalize folder paths (remove trailing slashes)
' ------------------------------------------------------------
Public Function NormalizePath(ByVal p As String) As String
On Error GoTo PathError
If Right$(p, 1) = "\" Then
NormalizePath = Left$(p, Len(p) - 1)
Else
NormalizePath = p
End If
Exit Function
PathError:
NormalizePath = p
End Function
' ------------------------------------------------------------
' 5. Safe value getter (avoids errors on empty cells)
' ------------------------------------------------------------
Public Function SafeValue(ByVal v As Variant) As String
On Error Resume Next
If IsEmpty(v) Or IsNull(v) Then
SafeValue = ""
Else
SafeValue = CStr(v)
End If
End Function
' ============================================================
' LOAD EXTRACTED TEXT FROM HASH-NAMED TEXT FILE
' ============================================================
Public Function LoadExtractedText(ByVal hashVal As String) As String
Dim textPath As String
Dim f As Integer
Dim content As String
' Build full path to extracted text file
textPath = TEXT_STORAGE_ROOT & "\" & hashVal & ".txt"
' If file does not exist, return empty
If Dir(textPath) = "" Then
LoadExtractedText = ""
Exit Function
End If
' Read file content
f = FreeFile
Open textPath For Input As #f
content = Input$(LOF(f), f)
Close #f
LoadExtractedText = content
End Function
Public Function LoadTextFile(filePath As String) As String
Dim f As Integer
f = FreeFile
Open filePath For Input As #f
LoadTextFile = Input$(LOF(f), f)
Close #f
End Function
Public Function ExtractMediaMetadataFromUNCLETOM(meta As Object, ext As String) As String
' Placeholder implementation
ExtractMediaMetadataFromUNCLETOM = ""
End Function
------------------------------------------------------------
============================================================
FILE: modZipEngine.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modZipEngine.txt
============================================================
Option Explicit
' ============================================================
' ZIP ENGINE
' Creates ZIP files from export folders using Windows Shell.
' Safe, native, no external dependencies.
' Skips protected dev folder ("Excel Programming")
' ============================================================
' ------------------------------------------------------------
' 1. Create a ZIP file from a folder
' ------------------------------------------------------------
Public Sub CreateZipFromFolder(ByVal sourceFolder As String, ByVal zipName As String)
Dim fso As Object
Dim zipPath As String
Dim shellApp As Object
Dim parentFolder As String
On Error GoTo ZipError
' Ensure MASTER_ROOT is initialized
If Not MASTER_ROOT_INITIALIZED Then
Call InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Set fso = CreateObject("Scripting.FileSystemObject")
' Safety check
If Not fso.FolderExists(sourceFolder) Then
MsgBox "Source folder not found: " & sourceFolder, vbExclamation
Exit Sub
End If
' ------------------------------------------------------------
' PROTECTED FOLDER CHECK
' Never ZIP the protected dev folder
' ------------------------------------------------------------
If IsProtectedDevFolder(sourceFolder) Then
MsgBox "ZIP operation blocked: protected folder (" & PROTECTED_DEV_FOLDER_NAME & ")", vbExclamation
Call LogAction(LOG_SOURCE_MASTER, sourceFolder, "ZIP SKIPPED", _
"Protected folder: " & PROTECTED_DEV_FOLDER_NAME)
Exit Sub
End If
' Build ZIP path
zipPath = NormalizePath(sourceFolder) & "\" & zipName & ".zip"
' If ZIP already exists, skip
If fso.FileExists(zipPath) Then
MsgBox "ZIP already exists: " & zipPath, vbExclamation
Exit Sub
End If
' Create empty ZIP file (Windows trick)
CreateEmptyZip zipPath
' Use Windows Shell to copy files into ZIP
Set shellApp = CreateObject("Shell.Application")
shellApp.Namespace(zipPath).CopyHere shellApp.Namespace(sourceFolder).Items
' Wait for ZIP to finish (simple delay)
Application.Wait Now + TimeValue("0:00:02")
Call LogAction(LOG_SOURCE_MASTER, zipPath, "ZIP CREATED", _
"Created ZIP from folder: " & sourceFolder)
MsgBox "ZIP created: " & zipPath, vbInformation
Exit Sub
ZipError:
MsgBox "Error creating ZIP: " & Err.description, vbCritical, "ZIP Error"
End Sub
' ------------------------------------------------------------
' 2. Create an empty ZIP file (required by Windows)
' ------------------------------------------------------------
Private Sub CreateEmptyZip(ByVal zipPath As String)
Dim fso As Object
Dim zipHeader As String
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
' Standard ZIP file header bytes
zipHeader = "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
' Write header to file
Set ts = fso.CreateTextFile(zipPath, True)
ts.Write zipHeader
ts.Close
End Sub
' ------------------------------------------------------------
' 3. ZIP an export folder by name
' ------------------------------------------------------------
Public Sub ZipExport(ByVal exportName As String)
Dim exportFolder As String
' Ensure MASTER_ROOT is initialized
If Not MASTER_ROOT_INITIALIZED Then
Call InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
exportFolder = NormalizePath(MASTER_ROOT) & "\Exports\" & exportName
Call CreateZipFromFolder(exportFolder, exportName)
End Sub
------------------------------------------------------------
============================================================
FILE: Ribbon_Custom_UI_XML.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\Ribbon_Custom_UI_XML.txt
============================================================
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui" onLoad="RibbonOnLoad">
<ribbon>
<tabs>
<tab id="tabDocSystem" label="Document System">
<!-- CORE GROUP -->
<group id="grpCore" label="Core">
<button id="btnScan" label="Scan" onAction="Ribbon_Scan"/>
<button id="btnPreviewRenames" label="Preview Renames" onAction="PreviewRenames"/>
<button id="btnApplyRenames" label="Apply Renames" onAction="UI_ApplyRenames"/>
<button id="btnSync" label="Sync Folder" onAction="UI_Sync"/>
</group>
<!-- SEARCH & EXPORT GROUP -->
<group id="grpSearchExport" label="Search & Export">
<button id="btnSearch" label="Search" onAction="UI_Search"/>
<button id="btnExportSearch" label="Export Search" onAction="UI_ExportSearch"/>
<button id="btnZipExport" label="ZIP Export" onAction="UI_ZipExport"/>
<button id="btnEmailExport" label="Email Export" onAction="UI_EmailExport"/>
<button id="btnPrintSearch" label="Print Search" onAction="UI_PrintSearch"/>
</group>
<!-- CASES GROUP -->
<group id="grpCases" label="Cases">
<button id="btnExportCase" label="Export Case" onAction="UI_ExportCase"/>
<button id="btnEmailCase" label="Email Case" onAction="UI_EmailCase"/>
<button id="btnPrintCase" label="Print Case" onAction="UI_PrintCase"/>
</group>
<!-- DIAGNOSTICS GROUP -->
<group id="grpDiagnostics" label="Diagnostics">
<button id="btnSystemHealth" label="System Health" onAction="UI_SystemHealth"/>
<button id="btnIndexIntegrity" label="Index Integrity" onAction="UI_IndexIntegrity"/>
<button id="btnFolderConsistency" label="Folder Consistency" onAction="UI_FolderConsistency"/>
<button id="btnLogSummary" label="Log Summary" onAction="UI_LogSummary"/>
<button id="btnSystemInfo" label="System Info" onAction="UI_SystemInfo"/>
</group>
</tab>
</tabs>
</ribbon>
</customUI>
------------------------------------------------------------
--- END OF FILE: All Modules_Version 1.0(UNCLETOM).txt ---
=== FILE: All Modules_Version 1.0.txt | PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Version 2.0\Master Guide V 2.0\Old Guides\All Modules_Version 1.0.txt | MODIFIED: 02/09/2026 17:40:52 ===
============================================================
FILE: modApplyRenames.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modApplyRenames.txt
============================================================
Option Explicit
' ============================================================
' APPLY RENAMES ENGINE
' Safely renames files based on Preview Mode.
' - Checks for conflicts
' - Renames files atomically
' - Updates Master Index
' - Logs all actions
' - Respects protected dev folder ("Excel Programming")
' ============================================================
' ------------------------------------------------------------
' 1. MAIN ENTRY POINT
' ------------------------------------------------------------
Public Sub ApplyRenames()
Dim wsPrev As Worksheet
Dim lastRow As Long
Dim i As Long
Dim oldName As String
Dim newName As String
Dim relFolder As String
Dim oldPath As String
Dim newPath As String
Dim fullFolderPath As String
On Error GoTo RenameError
' Ensure MASTER_ROOT is initialized
If Not MASTER_ROOT_INITIALIZED Then
Call InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Set wsPrev = ThisWorkbook.Worksheets(SHEET_PREVIEW)
lastRow = wsPrev.Cells(wsPrev.Rows.Count, 1).End(xlUp).Row
If lastRow < 2 Then
MsgBox "Preview Mode is empty. Run Scan first.", vbExclamation
Exit Sub
End If
' --------------------------------------------------------
' LOOP THROUGH PREVIEW ROWS
' --------------------------------------------------------
For i = 2 To lastRow
' Only rename rows marked Pending
If SafeValue(wsPrev.Cells(i, 5).Value) <> "Pending" Then GoTo NextRow
oldName = SafeValue(wsPrev.Cells(i, 1).Value)
newName = SafeValue(wsPrev.Cells(i, 2).Value)
relFolder = SafeValue(wsPrev.Cells(i, 3).Value)
' Build full folder path
If relFolder = "" Then
fullFolderPath = MASTER_ROOT
Else
fullFolderPath = MASTER_ROOT & "\" & relFolder
End If
' ----------------------------------------------------
' PROTECTED FOLDER CHECK
' ----------------------------------------------------
If IsProtectedDevFolder(fullFolderPath) Then
wsPrev.Cells(i, 5).Value = "Skipped (Protected Folder)"
Call LogAction(LOG_SOURCE_MASTER, fullFolderPath, "RENAME SKIPPED", _
"Protected folder: " & PROTECTED_DEV_FOLDER_NAME)
GoTo NextRow
End If
' ----------------------------------------------------
' BUILD FULL PATHS
' ----------------------------------------------------
If relFolder = "" Then
oldPath = MASTER_ROOT & "\" & oldName
newPath = MASTER_ROOT & "\" & newName
Else
oldPath = MASTER_ROOT & "\" & relFolder & "\" & oldName
newPath = MASTER_ROOT & "\" & relFolder & "\" & newName
End If
' ----------------------------------------------------
' VALIDATE PATHS
' ----------------------------------------------------
If Not FileExists(oldPath) Then
wsPrev.Cells(i, 5).Value = "Missing"
Call LogAction(LOG_SOURCE_MASTER, oldPath, "RENAME SKIPPED", "Original file not found")
GoTo NextRow
End If
If FileExists(newPath) Then
wsPrev.Cells(i, 5).Value = "Conflict"
Call LogAction(LOG_SOURCE_MASTER, newPath, "RENAME SKIPPED", "Target name already exists")
GoTo NextRow
End If
' ----------------------------------------------------
' ATTEMPT RENAME
' ----------------------------------------------------
If SafeRenameFile(oldPath, newPath) Then
wsPrev.Cells(i, 5).Value = "Renamed"
Call LogAction(LOG_SOURCE_MASTER, newPath, "RENAME SUCCESS", "Renamed from " & oldName)
' Update Master Index
Call UpdateMasterIndex(newPath, relFolder, newName, wsPrev.Cells(i, 4).Value)
Else
wsPrev.Cells(i, 5).Value = "Error"
Call LogAction(LOG_SOURCE_MASTER, oldPath, "RENAME FAILED", "Rename operation failed")
End If
NextRow:
Next i
MsgBox "Renaming complete. Review Preview Mode for results.", vbInformation
Exit Sub
RenameError:
MsgBox "Error applying renames: " & Err.Description, vbCritical, "Rename Error"
End Sub
' ------------------------------------------------------------
' 2. SAFE RENAME WRAPPER
' ------------------------------------------------------------
Private Function SafeRenameFile(ByVal oldPath As String, ByVal newPath As String) As Boolean
On Error GoTo RenameFail
Name oldPath As newPath
SafeRenameFile = True
Exit Function
RenameFail:
SafeRenameFile = False
End Function
' ------------------------------------------------------------
' 3. FILE EXISTS CHECK
' ------------------------------------------------------------
Private Function FileExists(ByVal filePath As String) As Boolean
On Error Resume Next
FileExists = (Dir(filePath) <> "")
End Function
' ------------------------------------------------------------
' 4. SAFE VALUE (NULL/EMPTY PROTECTION)
' ------------------------------------------------------------
Private Function SafeValue(v As Variant) As String
If IsError(v) Then
SafeValue = ""
ElseIf IsNull(v) Then
SafeValue = ""
Else
SafeValue = Trim$(CStr(v))
End If
End Function
------------------------------------------------------------
============================================================
FILE: modCaseMapping.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modCaseMapping.txt
============================================================
Option Explicit
' ============================================================
' CASE MAPPING ENGINE
' Links files to cases using the Case Mapping sheet.
' Supports multi-case relationships.
' ============================================================
' ------------------------------------------------------------
' 1. Main entry point
' ------------------------------------------------------------
Public Sub ApplyCaseMapping()
Dim wsMap As Worksheet
Dim wsIndex As Worksheet
Dim lastRow As Long
Dim i As Long
Dim fileName As String
Dim relFolder As String
Dim fullPath As String
Dim caseList As String
On Error GoTo CaseError
Set wsMap = ThisWorkbook.Worksheets(SHEET_CASEMAP)
Set wsIndex = ThisWorkbook.Worksheets(SHEET_INDEX)
lastRow = wsMap.Cells(wsMap.Rows.Count, 1).End(xlUp).row
If lastRow < 2 Then
MsgBox "Case Mapping sheet is empty.", vbExclamation
Exit Sub
End If
' Loop through Case Mapping rows
For i = 2 To lastRow
fileName = SafeValue(wsMap.Cells(i, 1).Value)
relFolder = SafeValue(wsMap.Cells(i, 2).Value)
caseList = SafeValue(wsMap.Cells(i, 3).Value)
' Build full path
If relFolder = "" Then
fullPath = MASTER_ROOT & "\" & fileName
Else
fullPath = MASTER_ROOT & "\" & relFolder & "\" & fileName
End If
' Apply mapping
Call UpdateCaseMappingInIndex(fullPath, caseList)
Next i
MsgBox "Case mapping applied to Master Index.", vbInformation
Exit Sub
CaseError:
MsgBox "Error applying case mapping: " & Err.description, vbCritical, "Case Mapping Error"
End Sub
' ------------------------------------------------------------
' 2. Update case mapping inside Master Index
' ------------------------------------------------------------
Private Sub UpdateCaseMappingInIndex(ByVal fullPath As String, _
ByVal caseList As String)
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Set ws = ThisWorkbook.Worksheets(SHEET_INDEX)
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
' Find matching file
For i = 2 To lastRow
If SafeValue(ws.Cells(i, 4).Value) = fullPath Then
' Update case list
ws.Cells(i, 6).Value = caseList
Call LogAction(LOG_SOURCE_MASTER, fullPath, "CASE MAPPING", "Mapped to: " & caseList)
Exit Sub
End If
Next i
' If file not found
Call LogAction(LOG_SOURCE_MASTER, fullPath, "CASE MAPPING SKIPPED", "File not found in Master Index")
End Sub
------------------------------------------------------------
============================================================
FILE: modConfig.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modConfig.txt
============================================================
Option Explicit
' ============================================================
' MASTER CONFIGURATION
=== MODULE SECTION ===
MODULE
' ============================================================
' --- MASTER ROOT FOLDER (AUTHORITATIVE NAME ONLY) ---
Public Const MASTER_FOLDER_NAME As String = "Master_Doc_Management"
' --- PROTECTED INTERNAL FOLDER (ALWAYS EXCLUDED FROM SCANS) ---
Public Const PROTECTED_DEV_FOLDER_NAME As String = "Excel Programming"
' --- ONEDRIVE PERSONAL ROOT (STRICT) ---
' This is the ONLY path we auto-accept without user input.
Public Const ONEDRIVE_PERSONAL_ROOT As String = "C:\Users\remax\OneDrive\"
' --- HASH ALGORITHM (placeholder for future upgrade) ---
Public Const HASH_ALGO As String = "SHA1"
' --- MASTER FILE NAME ---
Public Const MASTER_FILE_NAME As String = "Master_Doc_Management.xlsm"
' --- CASE WORKBOOK TEMPLATE NAME ---
Public Const CASE_TEMPLATE_NAME As String = "Case_Template.xlsx"
' --- LOGGING OPTIONS ---
Public Const LOG_SOURCE_MASTER As String = "MASTER"
Public Const LOG_SOURCE_CASE As String = "CASE"
' --- VERSION ---
Public Const SYSTEM_VERSION As String = "1.0"
------------------------------------------------------------
============================================================
FILE: modConstants.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modConstants.txt
============================================================
Option Explicit
' --- SHEET NAMES (Canonical) ---
Public Const SHEET_INDEX As String = "Index"
Public Const SHEET_CASEMAP As String = "CaseMap"
Public Const SHEET_SERIAL As String = "Serial Counter"
Public Const SHEET_DUPES As String = "Duplicates"
Public Const SHEET_MISSING As String = "MissingMetadata"
Public Const SHEET_PREVIEW As String = "Preview"
Public Const SHEET_LOG As String = "Log"
Public Const SHEET_COLREG As String = "Column Registry"
Public Const SHEET_SETTINGS As String = "Settings"
Public Const SHEET_SEARCH_RESULTS As String = "SearchResults"
------------------------------------------------------------
============================================================
FILE: modDiagnosticsEngine.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modDiagnosticsEngine.txt
============================================================
Option Explicit
' ============================================================
' DIAGNOSTICS ENGINE
' ============================================================
Public Sub SystemHealthCheck()
Dim msg As String
Dim root As String
Dim ws As Worksheet
Dim requiredSheets As Variant
Dim i As Long
msg = ""
root = MASTER_ROOT
If Dir(root, vbDirectory) = "" Then
msg = msg & "- Master Root folder not found: " & root & vbCrLf
End If
requiredSheets = Array( _
SHEET_INDEX, _
SHEET_PREVIEW, _
SHEET_DUPES, _
SHEET_MISSING, _
SHEET_CASEMAP, _
SHEET_SETTINGS, _
SHEET_SEARCH_RESULTS, _
SHEET_SERIAL, _
SHEET_LOG, _
SHEET_COLREG _
)
For i = LBound(requiredSheets) To UBound(requiredSheets)
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(requiredSheets(i))
If ws Is Nothing Then
msg = msg & "- Missing sheet: " & requiredSheets(i) & vbCrLf
End If
Set ws = Nothing
On Error GoTo 0
Next i
If Not ValidateSettings() Then
msg = msg & "- Settings validation failed" & vbCrLf
End If
If msg = "" Then
MsgBox "System Health: OK" & vbCrLf & "All core components are present.", vbInformation
Else
MsgBox "System Health Issues:" & vbCrLf & vbCrLf & msg, vbExclamation
End If
End Sub
Public Sub IndexIntegrityCheck()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim issues As String
Dim fileName As String, fullPath As String, hashVal As String
Set ws = ThisWorkbook.Worksheets(SHEET_INDEX)
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
issues = ""
For i = 2 To lastRow
fileName = SafeValue(ws.Cells(i, 1).Value)
fullPath = SafeValue(ws.Cells(i, 4).Value)
hashVal = SafeValue(ws.Cells(i, 7).Value)
If fileName = "" Then issues = issues & "- Row " & i & ": Missing file name" & vbCrLf
If fullPath = "" Then issues = issues & "- Row " & i & ": Missing full path" & vbCrLf
If hashVal = "" Then issues = issues & "- Row " & i & ": Missing hash" & vbCrLf
Next i
If issues = "" Then
MsgBox "Index Integrity: OK" & vbCrLf & "No missing metadata detected.", vbInformation
Else
MsgBox "Index Integrity Issues:" & vbCrLf & vbCrLf & issues, vbExclamation
End If
End Sub
Public Sub FolderConsistencyCheck()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim fullPath As String
Dim fso As Object
Dim missing As String
Set ws = ThisWorkbook.Worksheets(SHEET_INDEX)
Set fso = CreateObject("Scripting.FileSystemObject")
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
missing = ""
For i = 2 To lastRow
fullPath = SafeValue(ws.Cells(i, 4).Value)
If fullPath <> "" Then
If Not fso.FileExists(fullPath) Then
missing = missing & "- Missing on disk: " & fullPath & vbCrLf
End If
End If
Next i
If missing = "" Then
MsgBox "Folder Consistency: OK" & vbCrLf & "All indexed files exist on disk.", vbInformation
Else
MsgBox "Folder Consistency Issues:" & vbCrLf & vbCrLf & missing, vbExclamation
End If
End Sub
Public Sub ShowLogSummary()
Dim ws As Worksheet
Dim lastRow As Long
Dim startRow As Long
Dim i As Long
Dim summary As String
Set ws = ThisWorkbook.Worksheets(SHEET_LOG)
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
startRow = Application.Max(2, lastRow - 49)
summary = ""
For i = startRow To lastRow
summary = summary & ws.Cells(i, 1).Value & " | " & _
ws.Cells(i, 2).Value & " | " & _
ws.Cells(i, 3).Value & " | " & _
ws.Cells(i, 4).Value & vbCrLf
Next i
If summary = "" Then summary = "(Log is empty)"
MsgBox "Last 50 Log Entries:" & vbCrLf & vbCrLf & summary, vbInformation
End Sub
Public Sub ShowSystemInfo()
Dim wsIndex As Worksheet
Dim wsCase As Worksheet
Dim fileCount As Long
Dim caseCount As Long
Dim lastScan As String
Dim lastSync As String
Set wsIndex = ThisWorkbook.Worksheets(SHEET_INDEX)
Set wsCase = ThisWorkbook.Worksheets(SHEET_CASEMAP)
fileCount = wsIndex.Cells(wsIndex.Rows.Count, 1).End(xlUp).row - 1
caseCount = wsCase.Cells(wsCase.Rows.Count, 1).End(xlUp).row - 1
lastScan = GetSettingValue("LastScan")
lastSync = GetSettingValue("LastSync")
MsgBox _
"System Information:" & vbCrLf & vbCrLf & _
"Master Root: " & MASTER_ROOT & vbCrLf & _
"Files Indexed: " & fileCount & vbCrLf & _
"Cases Defined: " & caseCount & vbCrLf & _
"Last Scan: " & lastScan & vbCrLf & _
"Last Sync: " & lastSync, _
vbInformation
End Sub
------------------------------------------------------------
============================================================
FILE: modDuplicateEngine.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modDuplicateEngine.txt
============================================================
Option Explicit
' ============================================================
' DUPLICATE DETECTION ENGINE
' Scans the Master Index for duplicate files based on:
' - Hash value
' - File size (from hash placeholder)
' - File name similarity
' Writes results to Duplicate Report sheet.
' Skips protected dev folder ("Excel Programming")
' ============================================================
' ------------------------------------------------------------
' 1. Main entry point
' ------------------------------------------------------------
Public Sub DetectDuplicates()
Dim wsIndex As Worksheet
Dim wsDupes As Worksheet
Dim lastRow As Long
Dim i As Long, j As Long
Dim NextRow As Long
Dim hashA As String, hashB As String
Dim fileA As String, fileB As String
Dim sizeA As String, sizeB As String
Dim reason As String
Dim pathA As String, pathB As String
Dim folderA As String, folderB As String
On Error GoTo DupError
' Ensure MASTER_ROOT is initialized
If Not MASTER_ROOT_INITIALIZED Then
Call InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Set wsIndex = ThisWorkbook.Worksheets(SHEET_INDEX)
Set wsDupes = ThisWorkbook.Worksheets(SHEET_DUPES)
' Clear old report
wsDupes.Cells.ClearContents
wsDupes.Range("A1:F1").Value = Array("File A", "File B", "Reason", "Hash", "Size", "Path")
lastRow = wsIndex.Cells(wsIndex.Rows.Count, 1).End(xlUp).row
NextRow = 2
' Compare each file with every other file
For i = 2 To lastRow - 1
fileA = SafeValue(wsIndex.Cells(i, 1).Value)
hashA = SafeValue(wsIndex.Cells(i, 7).Value)
sizeA = ExtractSizeFromHash(hashA)
pathA = SafeValue(wsIndex.Cells(i, 4).Value)
folderA = GetParentFolder(pathA)
' Skip protected folder
If IsProtectedDevFolder(folderA) Then GoTo NextI
For j = i + 1 To lastRow
fileB = SafeValue(wsIndex.Cells(j, 1).Value)
hashB = SafeValue(wsIndex.Cells(j, 7).Value)
sizeB = ExtractSizeFromHash(hashB)
pathB = SafeValue(wsIndex.Cells(j, 4).Value)
folderB = GetParentFolder(pathB)
' Skip protected folder
If IsProtectedDevFolder(folderB) Then GoTo NextJ
reason = ""
' 1. Exact hash match
If hashA <> "" And hashA = hashB Then
reason = "Exact duplicate (hash match)"
' 2. Same size + similar name
ElseIf sizeA <> "" And sizeA = sizeB Then
If AreNamesSimilar(fileA, fileB) Then
reason = "Possible duplicate (same size + similar name)"
End If
End If
' If duplicate found, write to report
If reason <> "" Then
wsDupes.Cells(NextRow, 1).Value = fileA
wsDupes.Cells(NextRow, 2).Value = fileB
wsDupes.Cells(NextRow, 3).Value = reason
wsDupes.Cells(NextRow, 4).Value = hashA
wsDupes.Cells(NextRow, 5).Value = sizeA
wsDupes.Cells(NextRow, 6).Value = pathA
NextRow = NextRow + 1
Call LogAction(LOG_SOURCE_MASTER, pathA, "DUPLICATE DETECTED", reason)
End If
NextJ:
Next j
NextI:
Next i
MsgBox "Duplicate detection complete.", vbInformation
Exit Sub
DupError:
MsgBox "Error detecting duplicates: " & Err.description, vbCritical, "Duplicate Error"
End Sub
' ------------------------------------------------------------
' 2. Extract file size from placeholder hash
' Hash format: size_timestamp
' ------------------------------------------------------------
Private Function ExtractSizeFromHash(ByVal hashVal As String) As String
On Error Resume Next
If InStr(hashVal, "_") > 0 Then
ExtractSizeFromHash = Split(hashVal, "_")(0)
Else
ExtractSizeFromHash = ""
End If
End Function
' ------------------------------------------------------------
' 3. Name similarity check
' ------------------------------------------------------------
Private Function AreNamesSimilar(ByVal nameA As String, ByVal nameB As String) As Boolean
Dim baseA As String, baseB As String
baseA = LCase$(RemoveExtension(nameA))
baseB = LCase$(RemoveExtension(nameB))
' Simple similarity check: one contains the other
If InStr(baseA, baseB) > 0 Or InStr(baseB, baseA) > 0 Then
AreNamesSimilar = True
Else
AreNamesSimilar = False
End If
End Function
' ------------------------------------------------------------
' 4. Remove file extension
' ------------------------------------------------------------
Private Function RemoveExtension(ByVal fileName As String) As String
If InStrRev(fileName, ".") > 0 Then
RemoveExtension = Left$(fileName, InStrRev(fileName, ".") - 1)
Else
RemoveExtension = fileName
End If
End Function
' ------------------------------------------------------------
' 5. Helper: Extract parent folder from full file path
' ------------------------------------------------------------
Private Function GetParentFolder(ByVal filePath As String) As String
Dim pos As Long
pos = InStrRev(filePath, "\")
If pos > 0 Then
GetParentFolder = Left(filePath, pos - 1)
Else
GetParentFolder = ""
End If
End Function
------------------------------------------------------------
============================================================
FILE: modEmailEngine.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modEmailEngine.txt
============================================================
Option Explicit
' ============================================================
' EMAIL ENGINE
' Creates Outlook email drafts with attachments.
' - Supports ZIP files
' - Supports export folders
' - Logs all email actions
' - NEVER sends automatically (safety)
' ============================================================
' ------------------------------------------------------------
' 1. Send a ZIP file by email (opens Outlook draft)
' ------------------------------------------------------------
Public Sub EmailZip(ByVal zipPath As String, ByVal recipient As String, Optional ByVal subjectText As String = "", Optional ByVal bodyText As String = "")
Dim outlookApp As Object
Dim mail As Object
Dim fso As Object
On Error GoTo EmailError
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(zipPath) Then
MsgBox "ZIP file not found: " & zipPath, vbExclamation
Exit Sub
End If
' Create Outlook instance
Set outlookApp = CreateObject("Outlook.Application")
Set mail = outlookApp.CreateItem(0) ' olMailItem
' Build email
mail.To = recipient
mail.Subject = IIf(subjectText = "", "Document Package", subjectText)
mail.Body = IIf(bodyText = "", "Please find the attached document package.", bodyText)
' Attach ZIP
mail.Attachments.Add zipPath
' Log
Call LogAction(LOG_SOURCE_MASTER, zipPath, "EMAIL PREPARED", "Email draft created for: " & recipient)
' Display email (never send automatically)
mail.Display
Exit Sub
EmailError:
MsgBox "Error preparing email: " & Err.description, vbCritical, "Email Error"
End Sub
' ------------------------------------------------------------
' 2. Email an export folder (ZIP it first)
' ------------------------------------------------------------
Public Sub EmailExport(ByVal exportName As String, ByVal recipient As String)
Dim exportFolder As String
Dim zipPath As String
exportFolder = MASTER_ROOT & "\Exports\" & exportName
' Create ZIP
Call CreateZipFromFolder(exportFolder, exportName)
zipPath = exportFolder & "\" & exportName & ".zip"
' Email ZIP
Call EmailZip(zipPath, recipient, "Export Package: " & exportName, "Attached is the export package: " & exportName)
End Sub
' ------------------------------------------------------------
' 3. Email a case package (export ? zip ? email)
' ------------------------------------------------------------
Public Sub EmailCase(ByVal caseID As String, ByVal recipient As String)
Dim exportName As String
exportName = "Case_" & caseID
' Export files for case
Call ExportCase(caseID)
' ZIP and email
Call EmailExport(exportName, recipient)
End Sub
------------------------------------------------------------
============================================================
FILE: modExifBatch.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modExifBatch.txt
============================================================
Option Explicit
' ============================================================
' BATCH EXIF & RENAME ENGINE (EXIFTOOL)
' ============================================================
' Your chosen temp folder
Private Const TEMP_ROOT As String = _
"C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Temp"
Private Const EXIF_ARGS As String = TEMP_ROOT & "\exif_args.txt"
Private Const EXIF_JSON As String = TEMP_ROOT & "\exif_output.json"
Private Const RENAME_ARGS As String = TEMP_ROOT & "\rename_args.txt"
' >>>> UPDATE THIS IF EXIFTOOL.EXE IS IN A DIFFERENT LOCATION <<<<
Private Const EXIFTOOL_EXE As String = TEMP_ROOT & "\exiftool.exe"
' ============================================================
' SUPPORT: ENSURE TEMP FOLDER EXISTS
' ============================================================
Private Sub EnsureTempFolder()
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(TEMP_ROOT) Then
fso.CreateFolder TEMP_ROOT
End If
End Sub
' ============================================================
' BATCH EXIF EXTRACTION
' - filePaths: Collection of full paths (String)
' - Writes JSON output to EXIF_JSON
' - You parse JSON and feed your existing description pipeline
' ============================================================
Public Sub RunBatchExifExtraction(ByVal filePaths As Collection)
Dim fNum As Integer
Dim i As Long
Dim cmd As String
Dim sh As Object
If filePaths Is Nothing Or filePaths.Count = 0 Then Exit Sub
EnsureTempFolder
' --------------------------------------------------------
' 1) BUILD ARGS FILE
' --------------------------------------------------------
fNum = FreeFile
Open EXIF_ARGS For Output As #fNum
Print #fNum, "-json"
Print #fNum, "-n" ' numeric GPS, numeric timestamps
Print #fNum, "-api" & " " & "largefilesupport=1"
For i = 1 To filePaths.Count
Print #fNum, """" & CStr(filePaths(i)) & """"
Next i
Close #fNum
' --------------------------------------------------------
' 2) RUN EXIFTOOL ONCE (HIDDEN)
' --------------------------------------------------------
Set sh = CreateObject("WScript.Shell")
cmd = """" & EXIFTOOL_EXE & """" & _
" -@" & """" & EXIF_ARGS & """" & _
" > " & """" & EXIF_JSON & """" & " 2>&1"
sh.Run cmd, 0, True ' 0 = hidden, True = wait
End Sub
' ============================================================
' BATCH RENAME ENGINE
' - wsPreview: sheet with OldPath + NewName
' - colOldPath: column number containing full old path
' - colNewName: column number containing new filename.ext
' ============================================================
Public Sub RunBatchRename(ByVal wsPreview As Worksheet, _
ByVal colOldPath As Long, _
ByVal colNewName As Long, _
ByVal firstDataRow As Long)
Dim lastRow As Long
Dim r As Long
Dim oldPath As String
Dim newName As String
Dim fNum As Integer
Dim cmd As String
Dim sh As Object
EnsureTempFolder
lastRow = wsPreview.Cells(wsPreview.Rows.Count, colOldPath).End(xlUp).Row
If lastRow < firstDataRow Then Exit Sub
' --------------------------------------------------------
' 1) BUILD RENAME ARGS FILE
' --------------------------------------------------------
fNum = FreeFile
Open RENAME_ARGS For Output As #fNum
Print #fNum, "-overwrite_original"
For r = firstDataRow To lastRow
oldPath = SafeValue(wsPreview.Cells(r, colOldPath).Value)
newName = SafeValue(wsPreview.Cells(r, colNewName).Value)
If oldPath <> "" And newName <> "" Then
Print #fNum, """" & oldPath & """"
Print #fNum, "-FileName=" & """" & newName & """"
End If
Next r
Close #fNum
' --------------------------------------------------------
' 2) RUN EXIFTOOL ONCE (HIDDEN)
' --------------------------------------------------------
Set sh = CreateObject("WScript.Shell")
cmd = """" & EXIFTOOL_EXE & """" & _
" -@" & """" & RENAME_ARGS & """" & " 2>&1"
sh.Run cmd, 0, True ' 0 = hidden, True = wait
End Sub
------------------------------------------------------------
============================================================
FILE: modExportEngine.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modExportEngine.txt
============================================================
Option Explicit
' ============================================================
' EXPORT ENGINE
' ============================================================
Public Sub ExportFileList(ByVal filePaths As Collection, ByVal exportName As String)
Dim exportFolder As String
Dim fso As Object
Dim filePath As Variant
Dim targetPath As String
Dim parentFolder As String
On Error GoTo ExportError
If Not MASTER_ROOT_INITIALIZED Then
Call InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Set fso = CreateObject("Scripting.FileSystemObject")
exportFolder = MASTER_ROOT & "\Exports\" & exportName
If Not fso.FolderExists(exportFolder) Then fso.CreateFolder exportFolder
For Each filePath In filePaths
parentFolder = GetParentFolder(CStr(filePath))
If IsProtectedDevFolder(parentFolder) Then
Call LogAction(LOG_SOURCE_MASTER, CStr(filePath), "EXPORT SKIPPED", _
"Protected folder: " & PROTECTED_DEV_FOLDER_NAME)
GoTo NextFile
End If
If fso.FileExists(filePath) Then
targetPath = exportFolder & "\" & fso.GetFileName(filePath)
fso.CopyFile filePath, targetPath, False
Call LogAction(LOG_SOURCE_MASTER, filePath, "EXPORT COPY", "Copied to " & targetPath)
Else
Call LogAction(LOG_SOURCE_MASTER, filePath, "EXPORT SKIPPED", "File not found")
End If
NextFile:
Next filePath
MsgBox "Export complete: " & exportFolder, vbInformation
Exit Sub
ExportError:
MsgBox "Error during export: " & Err.description, vbCritical, "Export Error"
End Sub
Public Sub ExportCase(ByVal caseID As String)
Dim wsIndex As Worksheet
Dim lastRow As Long
Dim i As Long
Dim filePaths As New Collection
Dim fullPath As String
Dim parentFolder As String
If Not MASTER_ROOT_INITIALIZED Then
Call InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Set wsIndex = ThisWorkbook.Worksheets(SHEET_INDEX)
lastRow = wsIndex.Cells(wsIndex.Rows.Count, 1).End(xlUp).row
For i = 2 To lastRow
If InStr(1, SafeValue(wsIndex.Cells(i, 6).Value), caseID, vbTextCompare) > 0 Then
fullPath = SafeValue(wsIndex.Cells(i, 4).Value)
parentFolder = GetParentFolder(fullPath)
If IsProtectedDevFolder(parentFolder) Then
Call LogAction(LOG_SOURCE_MASTER, fullPath, "EXPORT SKIPPED", _
"Protected folder: " & PROTECTED_DEV_FOLDER_NAME)
ElseIf fullPath <> "" Then
filePaths.Add fullPath
End If
End If
Next i
If filePaths.Count = 0 Then
MsgBox "No files found for case: " & caseID, vbExclamation
Exit Sub
End If
Call ExportFileList(filePaths, "Case_" & caseID)
End Sub
Public Sub ExportSearchResults()
Dim wsResults As Worksheet
Dim lastRow As Long
Dim i As Long
Dim filePaths As New Collection
Dim fullPath As String
Dim folderPath As String
Dim fileName As String
Dim parentFolder As String
' Ensure MASTER_ROOT is initialized
If Not MASTER_ROOT_INITIALIZED Then
InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Set wsResults = ThisWorkbook.Worksheets(SHEET_SEARCH_RESULTS)
' Determine last row with results
lastRow = wsResults.Cells(wsResults.Rows.Count, 1).End(xlUp).row
If lastRow < 5 Then
MsgBox "Search Results is empty. Run a search first.", vbExclamation
Exit Sub
End If
' ------------------------------------------------------------
' COLLECT FILE PATHS FROM SEARCH RESULTS
' ------------------------------------------------------------
For i = 5 To lastRow
fileName = SafeValue(wsResults.Cells(i, 1).Value) ' FileName
folderPath = SafeValue(wsResults.Cells(i, 2).Value) ' FolderPath
If fileName <> "" And folderPath <> "" Then
' Build full path
fullPath = folderPath & "\" & fileName
' Determine parent folder for protection check
parentFolder = GetParentFolder(fullPath)
' Skip protected dev folder
If IsProtectedDevFolder(parentFolder) Then
LogAction LOG_SOURCE_MASTER, fullPath, "EXPORT SKIPPED", _
"Protected folder: " & PROTECTED_DEV_FOLDER_NAME
Else
filePaths.Add fullPath
End If
End If
Next i
' ------------------------------------------------------------
' PERFORM EXPORT
' ------------------------------------------------------------
ExportFileList filePaths, "SearchExport_" & Format(Now, "yyyymmdd_hhnnss")
End Sub
Private Function GetParentFolder(ByVal filePath As String) As String
Dim pos As Long
pos = InStrRev(filePath, "\")
If pos > 0 Then
GetParentFolder = Left(filePath, pos - 1)
Else
GetParentFolder = ""
End If
End Function
------------------------------------------------------------
============================================================
FILE: modFileScanner.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modFileScanner.txt
============================================================
Option Explicit
' ============================================================
' FILE SCANNER
=== MODULE SECTION ===
MODULE
' Recursively scans the Master Root Folder and prepares
' Preview Mode for renaming. Does NOT rename anything.
' ============================================================
Public Sub ScanAndPreparePreview()
Dim wsPrev As Worksheet
Dim NextRow As Long
On Error GoTo ScanError
' Ensure MASTER_ROOT is initialized
If Not MASTER_ROOT_INITIALIZED Then
Call InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Set wsPrev = ThisWorkbook.Worksheets(SHEET_PREVIEW)
' Clear previous preview
wsPrev.Cells.ClearContents
' Headers
wsPrev.Range("A1:E1").Value = Array("OldName", "NewName", "Folder", "Hash", "Status")
NextRow = 2
' Begin recursive scan
Call ScanFolderRecursive(MASTER_ROOT, wsPrev, NextRow)
MsgBox "Scan complete. Review the Preview Mode sheet.", vbInformation
Exit Sub
ScanError:
MsgBox "Error during scan: " & Err.description, vbCritical, "Scan Error"
End Sub
' ============================================================
' RECURSIVE SCAN ENGINE
' ============================================================
Private Sub ScanFolderRecursive(ByVal folderPath As String, _
ByRef wsPrev As Worksheet, _
ByRef NextRow As Long)
Dim fso As Object
Dim folder As Object
Dim file As Object
Dim subFolder As Object
Dim fullPath As String
Dim ext As String
Dim relFolder As String
Dim hashVal As String
Dim extractedText As String
Set fso = CreateObject("Scripting.FileSystemObject")
' Safety check
If Not fso.FolderExists(folderPath) Then Exit Sub
Set folder = fso.GetFolder(folderPath)
' ============================================================
' PROCESS FILES IN THIS FOLDER
' ============================================================
For Each file In folder.Files
fullPath = file.path
ext = LCase(fso.GetExtensionName(fullPath))
' Compute hash
hashVal = GetFileHash(fullPath)
' Extract text depending on file type
extractedText = ""
If ext = "pdf" Then
extractedText = ExtractTextFromPDF(fullPath)
ElseIf ext = "docx" Then
extractedText = ExtractTextFromDocx(fullPath)
ElseIf ext = "jpg" Or ext = "jpeg" Or ext = "png" Then
extractedText = ExtractTextFromImage(fullPath)
ElseIf ext = "xlsx" Or ext = "xlsm" Then
extractedText = ExtractTextFromXLSX(fullPath)
End If
' Save extracted text externally
Call SaveExtractedText(hashVal, extractedText)
' Compute relative folder path
relFolder = Replace(folder.path, MASTER_ROOT, "")
If Left(relFolder, 1) = "\" Then relFolder = Mid(relFolder, 2)
' Write to Preview Mode
wsPrev.Cells(NextRow, 1).Value = file.Name
wsPrev.Cells(NextRow, 2).Value = "" ' NewName filled later
wsPrev.Cells(NextRow, 3).Value = relFolder
wsPrev.Cells(NextRow, 4).Value = hashVal
wsPrev.Cells(NextRow, 5).Value = "Pending"
NextRow = NextRow + 1
Next file
' ============================================================
' RECURSE INTO SUBFOLDERS
' ============================================================
For Each subFolder In folder.SubFolders
' Skip protected development folder
If IsProtectedDevFolder(subFolder.path) Then
' Do nothing
Else
Call ScanFolderRecursive(subFolder.path, wsPrev, NextRow)
End If
Next subFolder
End Sub
' ============================================================
' SAVE EXTRACTED TEXT TO EXTERNAL FILE
' ============================================================
Private Sub SaveExtractedText(ByVal hashVal As String, ByVal extractedText As String)
Dim outPath As String
Dim f As Integer
outPath = TEXT_STORAGE_ROOT & "\" & hashVal & ".txt"
f = FreeFile
Open outPath For Output As #f
Print #f, extractedText
Close #f
End Sub
' ============================================================
' XLSX TEXT EXTRACTION
' ============================================================
Private Function ExtractTextFromXLSX(ByVal filePath As String) As String
Dim xlApp As Object
Dim wb As Object
Dim ws As Object
Dim textOut As String
Dim r As Long, c As Long
Dim lastRow As Long, lastCol As Long
On Error GoTo CleanFail
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
xlApp.DisplayAlerts = False
Set wb = xlApp.Workbooks.Open(filePath, False, True) ' read-only
For Each ws In wb.Worksheets
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
textOut = textOut & vbCrLf & "=== Sheet: " & ws.Name & " ===" & vbCrLf
For r = 1 To lastRow
For c = 1 To lastCol
If Len(ws.Cells(r, c).Text) > 0 Then
textOut = textOut & ws.Cells(r, c).Text & " "
End If
Next c
textOut = textOut & vbCrLf
Next r
Next ws
CleanExit:
On Error Resume Next
wb.Close False
xlApp.Quit
Set wb = Nothing
Set xlApp = Nothing
ExtractTextFromXLSX = textOut
Exit Function
CleanFail:
ExtractTextFromXLSX = ""
Resume CleanExit
End Function
' ============================================================
' OCR IMAGE TEXT EXTRACTION
' ============================================================
Private Function ExtractTextFromImage(ByVal filePath As String) As String
Dim tempTxt As String
Dim cmd As String
Dim f As Integer
Dim content As String
tempTxt = Environ$("TEMP") & "\ocr_output.txt"
If Dir(tempTxt) <> "" Then Kill tempTxt
cmd = """" & TESSERACT_PATH & """ """ & filePath & """ """ & Environ$("TEMP") & "\ocr_output"" --oem 1 --psm 3"
Shell cmd, vbHide
Do While Dir(tempTxt) = ""
DoEvents
Loop
f = FreeFile
Open tempTxt For Input As #f
content = Input$(LOF(f), f)
Close #f
ExtractTextFromImage = content
End Function
------------------------------------------------------------
============================================================
FILE: modFolderSync.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modFolderSync.txt
============================================================
Option Explicit
' ============================================================
' FOLDER SYNC ENGINE
' Keeps the Master Index synchronized with the actual folder.
' Detects:
' - New files
' - Deleted files
' - Moved files
' ============================================================
' ------------------------------------------------------------
' 1. Main sync entry point
' ------------------------------------------------------------
Public Sub SyncFolder()
Dim wsIndex As Worksheet
Dim lastRow As Long
Dim i As Long
Dim fso As Object
Dim fileDict As Object
Dim fullPath As Variant
Dim relFolder As String
Dim fileName As String
On Error GoTo SyncError
' Ensure MASTER_ROOT is initialized
If Not MASTER_ROOT_INITIALIZED Then
Call InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then Exit Sub
End If
Set wsIndex = ThisWorkbook.Worksheets(SHEET_INDEX)
Set fso = CreateObject("Scripting.FileSystemObject")
Set fileDict = CreateObject("Scripting.Dictionary")
' STEP 1: Build dictionary of all files currently on disk
Call BuildFileDictionary(MASTER_ROOT, fileDict)
' STEP 2: Check Master Index for missing or moved files
lastRow = wsIndex.Cells(wsIndex.Rows.Count, 1).End(xlUp).row
For i = 2 To lastRow
fullPath = SafeValue(wsIndex.Cells(i, 4).Value)
fileName = SafeValue(wsIndex.Cells(i, 1).Value)
relFolder = SafeValue(wsIndex.Cells(i, 3).Value)
' If file no longer exists
If Not fso.FileExists(fullPath) Then
wsIndex.Cells(i, 10).Value = "Missing"
Call LogAction(LOG_SOURCE_MASTER, fullPath, "SYNC MISSING", "File no longer exists")
Else
wsIndex.Cells(i, 10).Value = "" ' Clear missing flag
End If
Next i
' STEP 3: Add new files not in Master Index
Call AddNewFilesToIndex(fileDict)
MsgBox "Folder sync complete.", vbInformation
Exit Sub
SyncError:
MsgBox "Error during folder sync: " & Err.description, vbCritical, "Sync Error"
End Sub
' ------------------------------------------------------------
' 2. Build dictionary of all files on disk
' (respects protected dev folder)
' ------------------------------------------------------------
Private Sub BuildFileDictionary(ByVal rootPath As String, ByRef dict As Object)
Dim fso As Object
Dim folder As Object
Dim file As Object
Dim subFolder As Object
Set fso = CreateObject("Scripting.FileSystemObject")
' Safety check
If Not fso.FolderExists(rootPath) Then Exit Sub
Set folder = fso.GetFolder(rootPath)
' Add files in this folder
For Each file In folder.Files
dict(file.path) = True
Next file
' Recurse into subfolders, skipping protected dev folder
For Each subFolder In folder.SubFolders
If IsProtectedDevFolder(subFolder.path) Then
' Skip "Excel Programming" entirely
Else
Call BuildFileDictionary(subFolder.path, dict)
End If
Next subFolder
End Sub
' ------------------------------------------------------------
' 3. Add new files to Master Index
' ------------------------------------------------------------
Private Sub AddNewFilesToIndex(ByVal dict As Object)
Dim wsIndex As Worksheet
Dim fullPath As Variant
Dim relFolder As String
Dim fileName As String
Dim hashVal As String
Dim fso As Object
Dim file As Object
Dim parentFolderPath As String
Set wsIndex = ThisWorkbook.Worksheets(SHEET_INDEX)
Set fso = CreateObject("Scripting.FileSystemObject")
' Loop through all files on disk
For Each fullPath In dict.Keys
' Check if file already exists in Master Index
If Not FileInIndex(CStr(fullPath)) Then
' Get file object
Set file = fso.GetFile(CStr(fullPath))
fileName = file.Name
parentFolderPath = file.parentFolder.path
' ----------------------------------------------------------------
' PROTECTED FOLDER CHECK
' If this file lives in the protected dev folder, skip it.
' This is a second safety net on top of the recursion exclusion.
' ----------------------------------------------------------------
If IsProtectedDevFolder(parentFolderPath) Then
Call LogAction(LOG_SOURCE_MASTER, CStr(fullPath), "SYNC SKIPPED", _
"Protected folder: " & PROTECTED_DEV_FOLDER_NAME)
GoTo NextFile
End If
' Compute relative folder
relFolder = Replace(parentFolderPath, MASTER_ROOT, "")
If Left(relFolder, 1) = "\" Then relFolder = Mid(relFolder, 2)
' Compute hash
hashVal = GetFileHash(CStr(fullPath))
' Insert into Master Index (from modIndexEngine)
Call InsertNewIndexRow(wsIndex, CStr(fullPath), fileName, hashVal)
' Log action
Call LogAction(LOG_SOURCE_MASTER, CStr(fullPath), "SYNC NEW FILE", "Added new file to index")
End If
NextFile:
Next fullPath
End Sub
' ------------------------------------------------------------
' 4. Check if file exists in Master Index
' ------------------------------------------------------------
Private Function FileInIndex(ByVal fullPath As String) As Boolean
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Set ws = ThisWorkbook.Worksheets(SHEET_INDEX)
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row
For i = 2 To lastRow
If SafeValue(ws.Cells(i, 4).Value) = fullPath Then
FileInIndex = True
Exit Function
End If
Next i
FileInIndex = False
End Function
------------------------------------------------------------
============================================================
FILE: modGlobals.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modGlobals.txt
============================================================
Option Explicit
' ============================================================
' GLOBAL RUNTIME VARIABLES
' These are initialized once and used across the entire system.
' ============================================================
Public MASTER_ROOT As String
Public MASTER_ROOT_INITIALIZED As Boolean
' ============================================================
' EXTERNAL TOOL PATHS
' All external utilities used by the extraction engine.
' ============================================================
Public Const TOOLS_ROOT As String = _
"C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\External_Tools\"
Public Const PDFTOTEXT As String = TOOLS_ROOT & "pdftotext\pdftotext.exe"
Public Const TESSERACT As String = TOOLS_ROOT & "tesseract\tesseract.exe"
Public Const EXIFTOOL As String = TOOLS_ROOT & "exiftool\exiftool.exe"
Public Const DOCX2TXT As String = TOOLS_ROOT & "docx2txt\docx2txt.exe"
Public Const XLSX2CSV As String = TOOLS_ROOT & "xlsx2csv\xlsx2csv.exe"
' Direct path to Tesseract (if needed by OCR routines)
Public Const TESSERACT_PATH As String = _
"C:\Program Files\Tesseract-OCR\tesseract.exe"
' ============================================================
' STORAGE LOCATIONS
' Where extracted text files are stored (isndexed by hash).
' ============================================================
Public Const TEXT_STORAGE_ROOT As String = _
"C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Extracted_Text"
' ============================================================
' COLUMN CONSTANTS FOR MASTER INDEX
' ============================================================
Public Const COL_SELECT As Long = 1
Public Const COL_FILEID As Long = 2
Public Const COL_CASEID As Long = 3
Public Const COL_FILENAME As Long = 4
Public Const COL_DESCRIPTION As Long = 5
Public Const COL_FILEPATH As Long = 6
Public Const COL_URL As Long = 7
Public Const COL_STATUS As Long = 8
Public Const COL_RELATED As Long = 9
Public Const COL_HASH As Long = 10
Public Const COL_LASTMOD As Long = 11
Public Const COL_LASTINDEXED As Long = 12
Public Const COL_HASH2 As Long = 13
Public Const COL_FLAGS As Long = 14
Public Const COL_
=== TASK SECTION ===
TASK As Long = 15
Public Const COL_TASKACTION As Long = 16
Public Const COL_TASKCATEGORY As Long = 17
Public Const COL_PRIORITY As Long = 18
Public Const COL_REMINDER As Long = 19
Public Const COL_FOLLOWUP As Long = 20
Public Const COL_NEXTACTION As Long = 21
Public Const COL_COMPLETED As Long = 22
Public EXIF_JSON As String
------------------------------------------------------------
============================================================
FILE: modHashEngine.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modHashEngine.txt
============================================================
Option Explicit
' ============================================================
' HASH ENGINE (Placeholder Version)
' Generates a pseudo-hash using file size + last modified date.
' Automatically skips protected dev folder ("Excel Programming").
' ============================================================
Public Function GetFileHash(ByVal filePath As String) As String
On Error GoTo HashError
Dim fso As Object
Dim f As Object
Dim parentFolder As String
' Ensure MASTER_ROOT is initialized
If Not MASTER_ROOT_INITIALIZED Then
Call InitializeMasterRootPath
If Not MASTER_ROOT_INITIALIZED Then
GetFileHash = "HASH_ERROR"
Exit Function
End If
End If
' Determine parent folder
parentFolder = GetParentFolder(filePath)
' ------------------------------------------------------------
' PROTECTED FOLDER CHECK
' Never hash files inside "Excel Programming"
' ------------------------------------------------------------
If IsProtectedDevFolder(parentFolder) Then
GetFileHash = "PROTECTED_FOLDER"
Exit Function
End If
Set fso = CreateObject("Scripting.FileSystemObject")
' Safety check
If Not fso.FileExists(filePath) Then
GetFileHash = "MISSING"
Exit Function
End If
Set f = fso.GetFile(filePath)
' Placeholder hash: size + last modified timestamp
GetFileHash = CStr(f.Size) & "_" & Format(f.DateLastModified, "yyyymmddhhmmss")
Exit Function
HashError:
GetFileHash = "HASH_ERROR"
End Function
' ------------------------------------------------------------
' Helper: Extract parent folder from full file path
' ------------------------------------------------------------
Private Function GetParentFolder(ByVal filePath As String) As String
Dim pos As Long
pos = InStrRev(filePath, "\")
If pos > 0 Then
GetParentFolder = Left(filePath, pos - 1)
Else
GetParentFolder = ""
End If
End Function
------------------------------------------------------------
============================================================
FILE: modIndexEngine.txt
FULL PATH: C:\Users\remax\OneDrive\Master_Doc_Management\Excel Programming\Modules\All Files\modIndexEngine.txt
============================================================
Option Explicit
' ============================================================
' MASTER INDEX ENGINE
' Updates the Master Index sheet with scanned file data.
' - Adds new rows for new files
' - Updates existing rows for existing files
' - Uses hash-based text extraction
' - Uses per-extension counters for FileID (PDF0000001, etc.)
' ============================================================
Private Const SHEET_COUNTERS As String = "Counters"
' ---- COLUMN MAP (based on your final header row) ----
Private Const COL_SELECT As Long = 1 ' Select (checkbox later)
Private Const COL_FILEID As Long = 2 ' FileID (EXT + sequence)
Private Const COL_CASEID As Long = 3 ' CaseID
Private Const COL_FILENAME As Long = 4 ' FileName (full, with extension)
Private Const COL_DESCRIPTION As Long = 5 ' Description
Private Const COL_FILEPATH As Long = 6 ' FilePath
Private Const COL_URL As Long = 7 ' URL
Private Const COL_STATUS As Long = 8 ' Status
Private Const COL_RELATEDCASES As Long = 9 ' Related Case(s)
Private Const COL_HASH As Long = 10 ' Hash
Private Const COL_LASTMODIFIED As Long = 11 ' LastModified
Private Const COL_LASTINDEXED As Long = 12 ' Last Indexed
Private Const COL_HASH_DUP As Long = 13 ' Hash (duplicate legacy)
Private Const COL_FLAGS As Long = 14 ' Flags
Private Const COL_
=== TASK SECTION ===
TASK As Long = 15 '
=== TASK SECTION ===
Task
Private Const COL_TASK_ACTIONTYPE As Long = 16 '
=== TASK SECTION ===
Task Action Type
Private Const COL_TASK_CATEGORY As Long = 17 '
=== TASK SECTION ===
Task Category
Private Const COL_PRIORITY As Long = 18 ' Priority
Private Const COL_REMINDER_DATE As Long = 19 ' Reminder Date
Private Const COL_FOLLOWUP_DATE As Long = 20 ' Follow-Up Date
Private Const COL_NEXT_ACTION As Long = 21 ' Next Action
Private Const COL_COMPLETED As Long = 22 ' Completed
' ------------------------------------------------------------
' 1. Update or insert a file into the Master Index
' ------------------------------------------------------------
Public