Insert_Picture_to_Excel

Sub InsertPicturesWithDialog()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim fullPath As String
    Dim picNum As String
    Dim shp As Shape
    Dim targetCell As Range
    Dim folderPath As String
    Dim successCount As Long
    Dim picWidth As Double
    Dim picHeight As Double
    
    ' Variables for user input
    Dim numberColumn As String
    Dim pictureColumn As String
    Dim widthInput As String
    Dim heightInput As String
    Dim unitInput As String
    Dim numberCol As Long
    Dim pictureCol As Long
    Dim widthValue As Double
    Dim heightValue As Double
    
    ' Get folder path
    folderPath = InputBox("Enter the folder path where images are stored:" & vbCrLf & vbCrLf & _
                         "Example: C:\Users\User\Downloads\Images", _
                         "Image Folder Path", _
                         "C:\Users\User\Downloads\")
    
    If folderPath = "" Then
        MsgBox "Operation cancelled.", vbInformation
        Exit Sub
    End If
    
    ' Ensure folder path ends with backslash
    If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
    
    ' Check if folder exists
    If Dir(folderPath, vbDirectory) = "" Then
        MsgBox "Folder not found! Please check the path.", vbCritical
        Exit Sub
    End If
    
    ' Get column with numbers
    numberColumn = InputBox("Enter the column letter that contains the numbers:" & vbCrLf & vbCrLf & _
                           "Example: B", _
                           "Number Column", _
                           "B")
    
    If numberColumn = "" Then
        MsgBox "Operation cancelled.", vbInformation
        Exit Sub
    End If
    
    numberCol = Range(numberColumn & "1").Column
    
    ' Get column for pictures
    pictureColumn = InputBox("Enter the column letter where pictures should be placed:" & vbCrLf & vbCrLf & _
                            "Example: J", _
                            "Picture Column", _
                            "J")
    
    If pictureColumn = "" Then
        MsgBox "Operation cancelled.", vbInformation
        Exit Sub
    End If
    
    pictureCol = Range(pictureColumn & "1").Column
    
    ' Get unit of measurement
    unitInput = InputBox("Select unit of measurement:" & vbCrLf & vbCrLf & _
                        "Enter:" & vbCrLf & _
                        "  'in' or 'inch' for inches" & vbCrLf & _
                        "  'cm' for centimeters" & vbCrLf & _
                        "  'mm' for millimeters", _
                        "Unit of Measurement", _
                        "cm")
    
    If unitInput = "" Then
        MsgBox "Operation cancelled.", vbInformation
        Exit Sub
    End If
    
    ' Normalize unit input
    unitInput = LCase(Trim(unitInput))
    If unitInput <> "in" And unitInput <> "inch" And unitInput <> "cm" And unitInput <> "mm" Then
        MsgBox "Invalid unit! Please enter 'in', 'cm', or 'mm'.", vbCritical
        Exit Sub
    End If
    
    ' Get picture width
    widthInput = InputBox("Enter picture width in " & unitInput & ":" & vbCrLf & vbCrLf & _
                          "Example: 7.2 (for " & unitInput & ")", _
                          "Picture Width", _
                          "7.2")
    
    If widthInput = "" Then
        MsgBox "Operation cancelled.", vbInformation
        Exit Sub
    End If
    
    If Not IsNumeric(widthInput) Then
        MsgBox "Invalid width! Please enter a number.", vbCritical
        Exit Sub
    End If
    
    widthValue = CDbl(widthInput)
    
    ' Get picture height
    heightInput = InputBox("Enter picture height in " & unitInput & ":" & vbCrLf & vbCrLf & _
                           "Example: 9.6 (for " & unitInput & ")", _
                           "Picture Height", _
                           "9.6")
    
    If heightInput = "" Then
        MsgBox "Operation cancelled.", vbInformation
        Exit Sub
    End If
    
    If Not IsNumeric(heightInput) Then
        MsgBox "Invalid height! Please enter a number.", vbCritical
        Exit Sub
    End If
    
    heightValue = CDbl(heightInput)
    
    ' Convert to points (1 inch = 72 points)
    Select Case unitInput
        Case "in", "inch"
            picWidth = widthValue * 72
            picHeight = heightValue * 72
        Case "cm"
            picWidth = (widthValue / 2.54) * 72  ' cm to inches to points
            picHeight = (heightValue / 2.54) * 72
        Case "mm"
            picWidth = (widthValue / 25.4) * 72  ' mm to inches to points
            picHeight = (heightValue / 25.4) * 72
    End Select
    
    ' Confirm settings
    Dim confirmMsg As String
    confirmMsg = "Please confirm your settings:" & vbCrLf & vbCrLf & _
                 "Folder: " & folderPath & vbCrLf & _
                 "Number Column: " & numberColumn & vbCrLf & _
                 "Picture Column: " & pictureColumn & vbCrLf & _
                 "Picture Size: " & widthInput & unitInput & " x " & heightInput & unitInput & vbCrLf & _
                 "              (" & Format(picWidth / 72, "0.00") & """ x " & Format(picHeight / 72, "0.00") & """)" & vbCrLf & vbCrLf & _
                 "Continue?"
    
    If MsgBox(confirmMsg, vbYesNo + vbQuestion, "Confirm Settings") = vbNo Then
        MsgBox "Operation cancelled.", vbInformation
        Exit Sub
    End If
    
    ' Start processing
    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, numberCol).End(xlUp).Row
    successCount = 0
    
    ' Loop through each row
    For i = 1 To lastRow
        picNum = Trim(ws.Cells(i, numberCol).Value)
        
        If IsNumeric(picNum) And picNum <> "" Then
            ' Try to find the image file
            fullPath = ""
            If Dir(folderPath & picNum & ".jpeg") <> "" Then
                fullPath = folderPath & picNum & ".jpeg"
            ElseIf Dir(folderPath & picNum & ".jpg") <> "" Then
                fullPath = folderPath & picNum & ".jpg"
            ElseIf Dir(folderPath & picNum & ".png") <> "" Then
                fullPath = folderPath & picNum & ".png"
            End If
            
            If fullPath <> "" Then
                Set targetCell = ws.Cells(i, pictureCol)
                
                ' Delete existing shapes/pictures in target column for this row
                On Error Resume Next
                Dim existingShp As Shape
                For Each existingShp In ws.Shapes
                    If existingShp.TopLeftCell.Row = i And _
                       existingShp.TopLeftCell.Column = pictureCol Then
                        existingShp.Delete
                    End If
                Next existingShp
                On Error GoTo 0
                
                ' Add picture as EMBEDDED
                Set shp = ws.Shapes.AddPicture( _
                    Filename:=fullPath, _
                    LinkToFile:=msoFalse, _
                    SaveWithDocument:=msoTrue, _
                    Left:=targetCell.Left + 5, _
                    Top:=targetCell.Top + 5, _
                    Width:=picWidth, _
                    Height:=picHeight)
                
                ' Set placement to move/size with cells
                With shp
                    .LockAspectRatio = msoFalse
                    .Placement = xlMoveAndSize
                End With
                
                successCount = successCount + 1
            End If
        End If
    Next i
    
    MsgBox successCount & " picture(s) embedded successfully!", vbInformation
End Sub

Attribute VB_Name = "Module1"
' Module-level variables to store settings
Public SavedFolderPath As String
Public SavedUnitChoice As String
Public SavedWidth As String
Public SavedHeight As String

Sub InsertPicturesWithTitleAbove()
    Dim folderPath As String
    Dim selectedCells As Range
    Dim cell As Range
    Dim fileNames() As String
    Dim filePaths() As String
    Dim fileCount As Long
    Dim i As Long
    Dim fileName As String
    Dim picWidth As Double
    Dim picHeight As Double
    Dim unitChoice As String
    Dim newPic As Shape
    Dim titleCell As Range
    Dim picCell As Range
    Dim widthInput As String
    Dim heightInput As String
    Dim useLastSettings As VbMsgBoxResult
    
    ' Check if settings exist from previous run
    If SavedFolderPath <> "" Then
        useLastSettings = MsgBox("Use previous settings?" & vbCrLf & vbCrLf & _
                                 "Folder: " & SavedFolderPath & vbCrLf & _
                                 "Unit: " & SavedUnitChoice & vbCrLf & _
                                 "Size: " & SavedWidth & " x " & SavedHeight & " " & SavedUnitChoice & vbCrLf & vbCrLf & _
                                 "Click 'Yes' to use these settings" & vbCrLf & _
                                 "Click 'No' to enter new settings", _
                                 vbYesNoCancel + vbQuestion, "Use Previous Settings?")
        
        If useLastSettings = vbCancel Then Exit Sub
        
        If useLastSettings = vbYes Then
            ' Use saved settings
            folderPath = SavedFolderPath
            unitChoice = SavedUnitChoice
            widthInput = SavedWidth
            heightInput = SavedHeight
            GoTo SkipSettings
        End If
    End If
    
    ' Browse for folder
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select folder containing images"
        .InitialFileName = SavedFolderPath ' Start at last used folder
        If .Show = -1 Then
            folderPath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With
    
    ' Get size settings
    unitChoice = InputBox("Size unit (cm/px/in):", "Unit", IIf(SavedUnitChoice = "", "cm", SavedUnitChoice))
    If unitChoice = "" Then Exit Sub
    unitChoice = LCase(Trim(unitChoice))
    
    widthInput = InputBox("Picture width:", "Width", IIf(SavedWidth = "", "12", SavedWidth))
    If Not IsNumeric(widthInput) Then Exit Sub
    
    heightInput = InputBox("Picture height:", "Height", IIf(SavedHeight = "", "8", SavedHeight))
    If Not IsNumeric(heightInput) Then Exit Sub
    
    ' Save settings for next time
    SavedFolderPath = folderPath
    SavedUnitChoice = unitChoice
    SavedWidth = widthInput
    SavedHeight = heightInput
    
SkipSettings:
    
    ' Collect all image files
    fileCount = 0
    ReDim fileNames(0)
    ReDim filePaths(0)
    
    Dim extensions As Variant
    extensions = Array("*.jpg", "*.jpeg", "*.png", "*.gif", "*.bmp")
    
    Dim ext As Variant
    For Each ext In extensions
        fileName = Dir(folderPath & ext)
        Do While fileName <> ""
            ReDim Preserve fileNames(fileCount)
            ReDim Preserve filePaths(fileCount)
            fileNames(fileCount) = fileName
            filePaths(fileCount) = folderPath & fileName
            fileCount = fileCount + 1
            fileName = Dir()
        Loop
    Next ext
    
    If fileCount = 0 Then
        MsgBox "No images found!", vbExclamation
        Exit Sub
    End If
    
    ' Convert to points
    Select Case unitChoice
        Case "cm"
            picWidth = CDbl(widthInput) * 28.3465
            picHeight = CDbl(heightInput) * 28.3465
        Case "in"
            picWidth = CDbl(widthInput) * 72
            picHeight = CDbl(heightInput) * 72
        Case Else
            picWidth = CDbl(widthInput)
            picHeight = CDbl(heightInput)
    End Select
    
    ' Select TITLE cells (pictures will go below)
    On Error Resume Next
    Set selectedCells = Application.InputBox( _
        "Select cells for TITLES (pictures will appear below)" & vbCrLf & _
        "Found " & fileCount & " images - select " & fileCount & " cells", _
        "Select Title Cells", Type:=8)
    On Error GoTo 0
    
    If selectedCells Is Nothing Then Exit Sub
    
    ' Insert pictures
    Application.ScreenUpdating = False
    i = 0
    
    For Each cell In selectedCells.Cells
        If i >= fileCount Then Exit For
        
        Set titleCell = cell
        Set picCell = cell.Offset(1, 0).MergeArea ' Picture goes in merged area below
        
        ' Extract filename without extension
        Dim titleText As String
        titleText = Left(fileNames(i), InStrRev(fileNames(i), ".") - 1)
        
        ' Format title
        With titleCell
            .Value = titleText
            .Font.Bold = True
            .Font.Size = 11
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
            .WrapText = False
        End With
        
        ' Delete old pictures in this cell area
        On Error Resume Next
        Dim shp As Shape
        For Each shp In picCell.Parent.Shapes
            If Not Intersect(shp.TopLeftCell, picCell) Is Nothing Then
                shp.Delete
            End If
        Next shp
        On Error GoTo 0
        
        ' Insert picture
        Set newPic = picCell.Parent.Shapes.AddPicture( _
            fileName:=filePaths(i), _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoTrue, _
            Left:=picCell.Left + 2.3, _
            Top:=picCell.Top + 2.3, _
            Width:=picWidth, _
            Height:=picHeight)
        
        newPic.LockAspectRatio = msoFalse
        newPic.Placement = xlMoveAndSize
        
        i = i + 1
    Next cell
    
    Application.ScreenUpdating = True
    MsgBox i & " pictures with titles inserted!", vbInformation
End Sub

' Optional: Reset saved settings
Sub ResetPictureSettings()
    SavedFolderPath = ""
    SavedUnitChoice = ""
    SavedWidth = ""
    SavedHeight = ""
    MsgBox "Settings cleared! Next run will ask for new settings.", vbInformation
End Sub