Option Explicit
' --- GLOBAL EXCEL CONFIGURATION CONSTANTS ---
Private Const START_ROW As Long = 17 ' Data begins at row 17
Private Const PIC_COL_NUMBER As Long = 9 ' Column I numeric index
(Where images are displayed)
Private Const PATH_COL_NUMBER As Long = 8 ' Column H numeric index
(Where path string is stored for Word)
Private Const REF_COL_NUMBER As Long = 1 ' Column A: Ref No used
for naming reference
'
==============================================
=======================
' GLOBAL STARTUP PROTECTION ENGINE
'
==============================================
=======================
Private Sub Workbook_Open()
Dim ws As Worksheet
On Error Resume Next
' Apply drawing protection across all sheets automatically on startup
For Each ws In [Link]
[Link] DrawingObjects:=True, Contents:=False, Scenarios:=False,
UserInterfaceOnly:=True
Next ws
End Sub
'
==============================================
=======================
' GLOBAL DOUBLE-CLICK HANDLER (TRIGGERS ON ALL COMPLIANCE TABS)
'
==============================================
=======================
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal
Target As Range, Cancel As Boolean)
' Only trigger engine if user double-clicks inside the visual "Related Pics"
column (I)
If [Link] <> PIC_COL_NUMBER Or [Link] < START_ROW Then
Exit Sub
' Cancel the default Excel cell text cursor edit mode
Cancel = True
Dim fileDlg As FileDialog
Dim imgPath As Variant
Dim cleanNamesList As String
Dim targetCell As Range
Dim shp As Shape
Dim currentLeft As Single
Dim currentTop As Single
Dim padding As Single
' Scaling & Alignment Variables
Dim fileCount As Long
Dim idx As Long
Dim insertedShapes() As Shape
Dim defaultHeight As Single
Dim imgGap As Single
Dim totalWidth As Single
Dim maxCellWidth As Single
Dim finalHeight As Single
Dim scaleFactor As Single
Dim filenameOnly As String
Set targetCell = Target
padding = 2 ' 2pt safety margins inside the cell boundary
' Initialize Windows File Picker
Set fileDlg = [Link](3) ' msoFileDialogFilePicker
With fileDlg
.Title = "Select Construction Photos for Ref ID: " &
[Link]([Link], REF_COL_NUMBER).Text
.AllowMultiSelect = True
.[Link]
.[Link] "Images", "*.jpg; *.jpeg; *.png; *.bmp"
If .Show = -1 Then
fileCount = .[Link]
' --- LIMIT THE SELECTION TO A MAX OF 4 IMAGES ---
If fileCount > 4 Then
MsgBox "You can only select up to 4 images for a single item.",
vbExclamation, "Image Limit Exceeded"
Exit Sub
End If
ReDim insertedShapes(0 To fileCount - 1)
' Temporarily unprotect worksheet drawing layer to allow VBA shape
insertions
[Link]
' Clear existing shapes inside this specific row's image cell on the
active sheet (Sh)
For Each shp In [Link]
If Not [Link] Is Nothing Then
If [Link] = [Link] And
[Link] = PIC_COL_NUMBER Then
[Link]
End If
End If
Next shp
defaultHeight = 91 ' Best default size matching 95pt RowHeight (91
+ 4pt padding)
imgGap = 4 ' Beautiful visual gap between pictures
idx = 0
cleanNamesList = ""
' Loop 1: Load images at native aspect ratio and record references
For Each imgPath In .SelectedItems
filenameOnly = Mid(imgPath, InStrRev(imgPath, "\") + 1)
' Compile delimiter string for the hidden Word engine pipeline
If cleanNamesList = "" Then
cleanNamesList = filenameOnly
Else
cleanNamesList = cleanNamesList & ";" & filenameOnly
End If
' Insert image using -1, -1 dimensions to load the graphic's true
aspect ratio
Set shp = [Link]( _
Filename:=imgPath, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=[Link], _
Top:=[Link], _
Width:=-1, _
Height:=-1)
' Lock aspect proportions and explicitly set locked state for
protection
[Link] = msoTrue
[Link] = True
' Apply temporary default height to measure width correctly
[Link] = defaultHeight
' Store reference in array
Set insertedShapes(idx) = shp
idx = idx + 1
Next imgPath
' Calculate total combined width of all images + gaps at default
height
totalWidth = 0
For idx = 0 To fileCount - 1
totalWidth = totalWidth + insertedShapes(idx).Width
Next idx
totalWidth = totalWidth + (fileCount - 1) * imgGap
' Determine maximum width available inside Column I (Related Pics)
maxCellWidth = [Link] - (padding * 2)
' Calculate final scaled height to fit inside cell width boundaries
finalHeight = defaultHeight
If totalWidth > maxCellWidth Then
scaleFactor = maxCellWidth / totalWidth
finalHeight = defaultHeight * scaleFactor
' Impose a safe minimum height so scaled down images remain
readable
If finalHeight < 35 Then finalHeight = 35
End If
' Dynamically set the row height to perfectly wrap the scaled pictures
[Link] = finalHeight + (padding * 2)
' Loop 2: Arrange and position all images neatly side-by-side
currentLeft = [Link] + padding
currentTop = [Link] + padding
For idx = 0 To fileCount - 1
Set shp = insertedShapes(idx)
[Link] = finalHeight ' Adjusting height automatically scales
width proportionally
[Link] = currentLeft
[Link] = currentTop
currentLeft = currentLeft + [Link] + imgGap
Next idx
' Write the safe semicolon-separated path payload to Column H
(Column 8)
[Link]([Link], PATH_COL_NUMBER).Value = cleanNamesList
' Re-enforce drawing sheet protection to prevent individual click-
deletion
[Link] DrawingObjects:=True, Contents:=False, Scenarios:=False,
UserInterfaceOnly:=True
' Success confirmation directly inside Excel status bar
[Link] = "Successfully stitched " & fileCount & "
images into Row " & [Link] & " on sheet '" & [Link] & "'"
DoEvents
[Link] = False
End If
End With
End Sub
'
==============================================
=======================
' GLOBAL SHEET CHANGE HANDLER (MONITORS INTERCEPTED DELETE
COMMANDS)
'
==============================================
=======================
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As
Range)
Dim cell As Range
Dim shp As Shape
Dim affectedRow As Long
On Error Resume Next ' Guard against multi-cell selections causing
crashes
For Each cell In Target
If [Link] >= START_ROW Then
' Monitor Column H (Path string) or Column I (Related Pics cell)
If [Link] = PATH_COL_NUMBER Or [Link] =
PIC_COL_NUMBER Then
' Check if either Column H has been cleared OR the target cell in
Column I has been emptied
If Len(Trim([Link]([Link], PATH_COL_NUMBER).Value)) = 0 Or
([Link] = PIC_COL_NUMBER And IsEmpty([Link])) Then
affectedRow = [Link]
' Disable events temporarily so our programmatic clear doesn't
loop recursively
[Link] = False
' Temporarily unprotect sheet drawings to let VBA run
modifications
[Link]
' 1. Wipe the path reference clean in Column H
[Link](affectedRow, PATH_COL_NUMBER).Value = ""
' 2. Scan and delete all visual shapes inside Column I (Related
Pics) for this row
For Each shp In [Link]
If Not [Link] Is Nothing Then
If [Link] = affectedRow And
[Link] = PIC_COL_NUMBER Then
[Link]
End If
End If
Next shp
' 3. Shrink the row height back to standard dimensions (20pt)
[Link](affectedRow).RowHeight = 20
' Re-protect the drawing objects before enabling events
[Link] DrawingObjects:=True, Contents:=False,
Scenarios:=False, UserInterfaceOnly:=True
[Link] = True
End If
End If
End If
Next cell
End Sub