Insert multiple pictures keeping the original size

[gatobarbieri]

Hi I found this macro to insert several pictures but the problem is resize them and I need to keep the original size of pictures. Is there any instruction to make it. This is the macro that I used. Thanks
Sub INSERTPHOTOS()
Dim PosX, PosY, X, J As Integer
Dim QuanPic As Integer
Dim Route As String


Route = "C:\MYPICTURES\"
Quantity of pictures to load
QuanPic = 200
Left margin and upper margin to separate each picture
PosX = 30
PosY = 30
J = 1

If there is any shape it will be eliminating.

If ActiveSheet.DrawingObjects.Count > 0 Then
ActiveSheet.DrawingObjects.Select
Selection.Delete
End If

and I load the 200 pics from the directory.

For X = 1 To QuanPic

This If is to put new values and make 2 pictures per row
'este If es para asignar nuevos valores a las

If J = 3 Then
PosX = 30
PosY = PosY + 330
J = 1
End If

I insert the shape and left margin and upper margin I put the variables, and I fix the width and heigh in 200 units (this mesuarment I need to take from original size of pic)
'inserto una autoforma y como margen izq. y superior le paso las

ActiveSheet.Shapes.AddShape(msoShapeRectangle, PosX, PosY, 240, 240).Select

I indicate load the pictures used the variable Route and conecting number of picture with extension jpg

On Error Resume Next
Selection.ShapeRange.Fill.UserPicture _
Route & "Image" & X & ".jpg"
If Err.Number <> 0 Then
MsgBox "No find one of the pictures " _
& " check the directory ", vbCritical, "Error"
Err.Clear
Exit Sub
End If
Increase the left margin and to J

PosX = PosX + 330
J = J + 1
Next X
Range("a1").Select
End Sub '

 

[Dan_W]

Hi

Change this line:

ActiveSheet.Shapes.AddShape(msoShapeRectangle, PosX, PosY, 240, 240).Select

to

ActiveSheet.Shapes.AddShape(msoShapeRectangle, PosX, PosY, -1, -1).Select

and see if that works.

 

[gatobarbieri]

Hi

Change this line:

ActiveSheet.Shapes.AddShape(msoShapeRectangle, PosX, PosY, 240, 240).Select

to

ActiveSheet.Shapes.AddShape(msoShapeRectangle, PosX, PosY, -1, -1).Select

and see if that works.

Hi Thank you. I tried but do not work. It appereance the error message 1004 in ejectution time. The value insert is out of limitis.

 

[Dan_W]

Sorry, I wasn't paying close enough attention - I should you were using AddPicture, and not AddShape. The following line of code should work instead of the one I gave you above, but I would need to see your code in full (that is, not with your comments in-between) in order to work out where it should go and what other lines of code should change accordingly.

Call Application.ActiveSheet.Shapes.AddPicture(Filename:=Route & "Image" & X & ".jpg", LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=PosX, Top:=PosY, Width:=-1, Height:=-1)

Can you please post the relevant section of code in tags please, and then I can look at it properly. Thanks.

 

[gatobarbieri]

Sorry, I wasn't paying close enough attention - I should you were using AddPicture, and not AddShape. The following line of code should work instead of the one I gave you above, but I would need to see your code in full (that is, not with your comments in-between) in order to work out where it should go and what other lines of code should change accordingly.

Call Application.ActiveSheet.Shapes.AddPicture(Filename:=Route & "Image" & X & ".jpg", LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=PosX, Top:=PosY, Width:=-1, Height:=-1)

Can you please post the relevant section of code in tags please, and then I can look at it properly. Thanks.

Sub INSERTPHOTOS()
Dim PosX, PosY, X, J As Integer
Dim QuanPic As Integer
Dim Route As String
Route = "C:\MYPICTURES\"
QuanPic = 200
PosX = 30
PosY = 30
J = 1
If ActiveSheet.DrawingObjects.Count > 0 Then
ActiveSheet.DrawingObjects.Select
Selection.Delete
End If
For X = 1 To QuanPic
If J = 3 Then
PosX = 30
PosY = PosY + 330
J = 1
End If
ActiveSheet.Shapes.AddShape(msoShapeRectangle, PosX, PosY, 240, 240).Select
On Error Resume Next
Selection.ShapeRange.Fill.UserPicture _
Route & "Image" & X & ".jpg"
If Err.Number <> 0 Then
MsgBox "No find one of the pictures " _
& " check the directory ", vbCritical, "Error"
Err.Clear
Exit Sub
End If
PosX = PosX + 330
J = J + 1
Next X
Range("a1").Select
End Sub '

 

[gatobarbieri]

Thank for you time and the solution.

 

[Dan_W]

Hi. Hopefully this works. The benefit of using the AddPicture method is that it will automatically adjust the image to the actual size without any additional input from you. Let me know if you have any questions, but do let me know how it goes.

Sub INSERTPHOTOS()
    Dim PosX As Long, PosY As Long, X As Long, J As Long
    Dim QuanPic As Long
    Dim Route As String
    Dim ImageFilename As String
    
    On Error GoTo ErrHandler
    Route = "C:\MYPICTURES\"
    QuanPic = 200
    PosX = 30
    PosY = 30
    J = 1
    If ActiveSheet.DrawingObjects.count > 0 Then
        ActiveSheet.DrawingObjects.Delete
    End If
    For X = 1 To QuanPic
        If J = 3 Then
            PosX = 30
            PosY = PosY + 330
            J = 1
        End If
        ImageFilename = Route & "Image" & X & ".jpg"
        If Len(Dir(ImageFilename)) = 0 Then
            MsgBox "No find one of the pictures check the directory ", vbCritical, "Error"
            Exit Sub
        End If
        
        Call Application.ActiveSheet.Shapes.AddPicture(Filename:=ImageFilename, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=PosX, Top:=PosY, Width:=-1, Height:=-1)
        PosX = PosX + 330
        J = J + 1
    Next X
    Range("a1").Select
    Exit Sub
ErrHandler:
    MsgBox "Error #: " & Err.Number & vbNewLine & vbNewLine & Err.Description
End Sub '

 

[gatobarbieri]

Mister Dan Thank you so much, works well.

 

[Dan_W]

Glad to hear it!