Insert Pictures problem with macro

**encleadus** · 01-14-2013, 09:07 AM

Hi Folks,

I use a macro to import pictures from a folder, but is not working perfectly.
If you check, this macro (see txt attachment) insert pictures in a sheet and create "footers" above the picture with texts.
Somehow the pictures insert points moving down slowly, and I can see growing difference between the "footer" and the picture (after 10 pictures is around 1/8 cell size....)
Do you have any idea how can I fix it? (my row height is default: 12.75)

Thanks,

encleadus

**Jacc** · 01-14-2013, 09:16 AM

Check out how to post code here: http://www.excelforum.com/forum-rule...rum-rules.html

**encleadus** · 01-14-2013, 09:31 AM

Sorry,
here is my code:

Sub InsertPicture()

Dim myRow As Long
Dim picnum As Long: picnum = InputBox("Number of pictures")
For myRow = 1 To picnum * 33 Step 33
Cells(myRow, 1).Resize(2, 11).Merge

Next myRow

Dim c As range
Dim c2 As range
For Each c In ActiveSheet.UsedRange
If c.MergeCells Then
c.Interior.Color = RGB(146, 208, 80)
c.HorizontalAlignment = xlCenter
c.VerticalAlignment = xlCenter
c.Font.Bold = True
End If
Next
For Each c2 In ActiveSheet.UsedRange
If c2.MergeCells Then
c2.Borders.Weight = xlThin
End If
Next

Dim WksCell As range

For Each WksCell In ActiveSheet.UsedRange
    If WksCell.Interior.Color = RGB(146, 208, 80) Then
        If WksCell.MergeArea.Cells(1).Address = WksCell.Address Then
            i = i + 1
            WksCell = "PICTURE REFERENCE " & i
        End If
    End If
Next WksCell

    Dim ImgFldr As String:      ImgFldr = InputBox("Paste here the folder location") 'ex: C:\Images\Nature
    Dim CurrentFile As String:  CurrentFile = Dir(ImgFldr & "\")
    Dim ImgLocX As Long:        ImgLocX = 0
    Dim ImgLocY As Long:        ImgLocY = 25.5
    Dim ImgSpacing As Long:     ImgSpacing = 420.75
    
    Do While CurrentFile <> ""
        ActiveSheet.Shapes.AddPicture ImgFldr & "\" & CurrentFile, True, True, ImgLocX, ImgLocY, 528, 382.5

       
        If ImgLocX = 0 * ImgSpacing Then
            ImgLocX = 0
            ImgLocY = ImgLocY + ImgSpacing
        Else
            ImgLocX = ImgLocX + ImgSpacing
        End If
        
        CurrentFile = Dir()
    Loop
    ActiveSheet.Shapes.SelectAll
    With Selection.ShapeRange.Line
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorText1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
    End With
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
    .Zoom = 88
    End With
    Application.PrintCommunication = False
End Sub

**Jacc** · 01-14-2013, 11:20 AM

Excellent! I'm having a look now.

**Jacc** · 01-14-2013, 12:05 PM

I took the freedom to mess around quite a bit with your code and made some modifications to make it run faster.

I think this does what you want.

Option Explicit

Sub InsertPicture()
Dim i As Integer, r As Integer, MergeCellsX As Integer, MergeCellsY As Integer
Dim myRow As Integer, picnum As Integer
Dim TotalRowsBetweenPics As Integer
Dim ImgFldr As String, MerCellName As String
Dim CurrentFile As String
Dim ImgLocX As Long, ImgLocY As Long
Dim ImgWidth As Single, ImgHeight As Single
Dim c As Range
Dim FirstLoop As Boolean
'http://www.excelforum.com/excel-programming-vba-macros/890783-insert-pictures-problem-with-macro.html


picnum = InputBox("Number of pictures")
ImgFldr = InputBox("Paste here the folder location") 'ex: C:\Images\Nature
MergeCellsX = 11
MergeCellsY = 2
TotalRowsBetweenPics = 33
ImgWidth = 528
ImgHeight = 382.5
i = 1
FirstLoop = True
For myRow = 1 To picnum * TotalRowsBetweenPics Step TotalRowsBetweenPics
    MerCellName = "MerCell" & i
    ActiveSheet.Cells(myRow, 1).Resize(MergeCellsY, MergeCellsX).Name = MerCellName
    With ActiveSheet.Range(MerCellName)
        .Merge
        .Interior.Color = RGB(146, 208, 80)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Bold = True
        .Borders.Weight = xlThin
        .Value = "PICTURE REFERENCE " & i
    End With
    If FirstLoop = True Then
        CurrentFile = Dir(ImgFldr & "\")
        FirstLoop = False
    Else
        CurrentFile = Dir()
    End If
    ImgLocX = ActiveSheet.Range(MerCellName).Offset(1, 0).Left
    ImgLocY = ActiveSheet.Range(MerCellName).Offset(1, 0).Top
    ActiveSheet.Shapes.AddPicture ImgFldr & "\" & CurrentFile, True, True, ImgLocX, ImgLocY, ImgWidth, ImgHeight
    i = i + 1
Next myRow
ActiveSheet.Shapes.SelectAll
Selection.ShapeRange.Line.Visible = msoTrue
Application.PrintCommunication = False
ActiveSheet.PageSetup.Zoom = 88
Application.PrintCommunication = True
End Sub

**Jacc** · 01-14-2013, 12:23 PM

Good to hear it worked!

I don't know for sure what was wrong with your code, I think maybe Excel has a problem with decimal numbers in row heights.
That's why I skipped that and referenced the position to the closest header cell instead.

**encleadus** · 01-14-2013, 12:12 PM

Thank you very much, it's worked perfectly!
Could you tell what what was the problem with my code? Why changed the difference between the merged cells and the inserted pictures?

encleadus

**Jacc** · 01-14-2013, 12:13 PM

Here is a slight improvement, a basic errorhandling. If you specify more files than are available it just exits with no drama.

Option Explicit

Sub InsertPicture()
Dim i As Integer, r As Integer, MergeCellsX As Integer, MergeCellsY As Integer
Dim myRow As Integer, picnum As Integer
Dim TotalRowsBetweenPics As Integer
Dim ImgFldr As String, MerCellName As String
Dim CurrentFile As String
Dim ImgLocX As Long, ImgLocY As Long
Dim ImgWidth As Single, ImgHeight As Single
Dim c As Range
Dim FirstLoop As Boolean
'http://www.excelforum.com/excel-programming-vba-macros/890783-insert-pictures-problem-with-macro.html


picnum = InputBox("Number of pictures")
ImgFldr = InputBox("Paste here the folder location") 'ex: C:\Images\Nature
MergeCellsX = 11
MergeCellsY = 2
TotalRowsBetweenPics = 33
ImgWidth = 528
ImgHeight = 382.5
i = 1
FirstLoop = True
For myRow = 1 To picnum * TotalRowsBetweenPics Step TotalRowsBetweenPics
    If FirstLoop = True Then
        CurrentFile = Dir(ImgFldr & "\")
        FirstLoop = False
    Else
        CurrentFile = Dir()
    End If
    If CurrentFile = "" Then Exit Sub
    MerCellName = "MerCell" & i
    ActiveSheet.Cells(myRow, 1).Resize(MergeCellsY, MergeCellsX).Name = MerCellName
    With ActiveSheet.Range(MerCellName)
        .Merge
        .Interior.Color = RGB(146, 208, 80)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Bold = True
        .Borders.Weight = xlThin
        .Value = "PICTURE REFERENCE " & i
    End With

    ImgLocX = ActiveSheet.Range(MerCellName).Offset(1, 0).Left
    ImgLocY = ActiveSheet.Range(MerCellName).Offset(1, 0).Top
    ActiveSheet.Shapes.AddPicture ImgFldr & "\" & CurrentFile, True, True, ImgLocX, ImgLocY, ImgWidth, ImgHeight
    i = i + 1
Next myRow
ActiveSheet.Shapes.SelectAll
Selection.ShapeRange.Line.Visible = msoTrue
Application.PrintCommunication = False
ActiveSheet.PageSetup.Zoom = 88
Application.PrintCommunication = True
End Sub

**Jacc** · 01-14-2013, 12:36 PM

I didn't need different names for the ranges in the end. Forgot to clean that up.

Option Explicit

Sub InsertPicture2()
Dim i As Integer, r As Integer, MergeCellsX As Integer, MergeCellsY As Integer
Dim myRow As Integer, picnum As Integer
Dim TotalRowsBetweenPics As Integer
Dim ImgFldr As String
Dim CurrentFile As String
Dim ImgLocX As Long, ImgLocY As Long
Dim ImgWidth As Single, ImgHeight As Single
Dim CurrentRange As Range
Dim FirstLoop As Boolean
'http://www.excelforum.com/excel-programming-vba-macros/890783-insert-pictures-problem-with-macro.html


picnum = InputBox("Number of pictures")
ImgFldr = InputBox("Paste here the folder location") 'ex: C:\Images\Nature
MergeCellsX = 11
MergeCellsY = 2
TotalRowsBetweenPics = 33
ImgWidth = 528
ImgHeight = 382.5
i = 1
FirstLoop = True
For myRow = 1 To picnum * TotalRowsBetweenPics Step TotalRowsBetweenPics
    If FirstLoop = True Then
        CurrentFile = Dir(ImgFldr & "\")
        FirstLoop = False
    Else
        CurrentFile = Dir()
    End If
    If CurrentFile = "" Then Exit Sub
    Set CurrentRange = ActiveSheet.Cells(myRow, 1).Resize(MergeCellsY, MergeCellsX)
    With CurrentRange
        .Merge
        .Interior.Color = RGB(146, 208, 80)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Font.Bold = True
        .Borders.Weight = xlThin
        .Value = "PICTURE REFERENCE " & i
    End With

    ImgLocX = CurrentRange.Offset(1, 0).Left
    ImgLocY = CurrentRange.Offset(1, 0).Top
    ActiveSheet.Shapes.AddPicture ImgFldr & "\" & CurrentFile, True, True, ImgLocX, ImgLocY, ImgWidth, ImgHeight
    i = i + 1
Next myRow
ActiveSheet.Shapes.SelectAll
Selection.ShapeRange.Line.Visible = msoTrue
Application.PrintCommunication = False
ActiveSheet.PageSetup.Zoom = 88
Application.PrintCommunication = True
End Sub