Auto Picture Insert in Excel 2007

[pradeep.05]

I have a VBA code for Auto Picture insert in Excel from a network folder with reference to active cell size. This Macro works fine with the Excel 2003 but when working with 2007 the image size doesn't fits to the cell. Kindly go through the Following code & help me.
How It works I will tell you guys in Summary. Get the image name in one column which are stored on a network drive in An EXcel. Map the network drive on which images are stored. Then open the file wich is attached here. This file contains the VBA Code. & press Ctrl+L to auto insert the images in next to the columns where image name are mentioned.




Sub Jebs()
On Error GoTo errhandler:
Dim A
'A = Range(Mid(ActiveCell.Address, 2, 1) & 1)
A = Range(Mid(ActiveCell.Address, 2, InStr(2, ActiveCell.Address, "$") - 2) & 1)

If Range(A & ActiveCell.Row) = "" Then
MsgBox "No Design No", vbInformation
Exit Sub
End If

Set fso = CreateObject("Scripting.Filesystemobject")

If Not fso.driveexists("j:\") Then
MsgBox "j: Not Exists Or Not Enabled", vbExclamation
Exit Sub
End If

Set drv = fso.GetDrive(fso.GetDriveName("j:"))

'If drv.serialnumber <> -1871811936 Then
'MsgBox "Unauthorised copy of Picture Insert or you may have changed your disk drives"
' Exit Sub
'End If

If fso.fileexists("J:\facet photos\" & Replace(Range(A & ActiveCell.Row), " ", "") & ".jpg") Then
ActiveSheet.Pictures.Insert("J:\facet photos\" & Replace(Range(A & ActiveCell.Row), " ", "") & ".jpg").Select
Set Kfile = fso.getfile("J:\facet photos\" & Replace(Range(A & ActiveCell.Row), " ", "") & ".jpg")
Else
ActiveSheet.Pictures.Insert("J:\facet photos\" & Replace(Range(A & ActiveCell.Row), " ", "") & ".bmp").Select
Set Kfile = fso.getfile("J:\facet photos\" & Replace(Range(A & ActiveCell.Row), " ", "") & ".bmp")
End If

Selection.Left = ActiveCell.Left + 1
Selection.Top = ActiveCell.Top + 1
Selection.Height = ActiveCell.Height - 1
Selection.Width = ActiveCell.Width - 1
Range(Mid(ActiveCell.Address, 2, 1) & ActiveCell.Row + 1).Activate
Range((Mid(ActiveCell.Address, 2, 1)) & ActiveCell.Row).Select
Exit Sub


errhandler:
If Err.Number = 1004 Then
MsgBox "File with this Design No not found", vbInformation
Else
MsgBox Err.Description
End If
End Sub

[Kenneth Hobs]

Welcome to the forum! Please paste code between code tags. Click the # icon to insert the tags.

This does not do what you want but it might help. This keeps the picture's ratio the same. By making both the height and width the same as the cell, you could distort the image.

In this macro, the base file name like "ken" would be in the cell to the left of the activecell. The activecell is where the picture is imported and resized.

Sub ken()
Dim fn As String, pic As Object, r As Range
Set r = ActiveCell
fn = "c:\myfiles\excel\pics\" & r.Offset(, -1).Value2 & ".jpg"
If Len(Dir(fn)) = 0 Then
MsgBox "File: & fn & vblf & does not exist. Macro is ending", vbCritical, "Error"
Exit Sub
End If
Set pic = ActiveSheet.Pictures.Insert(fn)
FitPic r, pic
End Sub


'http://www.extendoffice.com/documents/excel/1060-excel-resize-picture-to-fit-cell.html
'Revised by Kenneth Hobson
Sub FitPic(aCell As Range, pic As Object)
Dim CellWtoHRatio As Single, PicWtoHRatio As Single

On Error GoTo NOT_SHAPE

With pic
PicWtoHRatio = .Width / .Height
End With

With aCell
CellWtoHRatio = .Width / .RowHeight
End With

Select Case PicWtoHRatio / CellWtoHRatio
Case Is > 1
With pic
.Width = aCell.Width
.Height = .Width / PicWtoHRatio
End With
Case Else
With pic
.Height = aCell.RowHeight
.Width = .Height * PicWtoHRatio
End With
End Select
With pic

[pradeep.05]

Dear Ken,

The Code you have given works for Local Disk & inserts a single Image where as the code i have given works for number of images whose names are mentioned in Column A & inserts the images next to name column from a network drive & not a Local drive. I will explain the working of my code in summary again: Pleas go through:

Get the image name in one column which are stored on a network drive in An Excel. Map the network drive on which images are stored. Then open the file wich is attached here. This file contains the VBA Code. After mapping the drive go to the exel file which contains name of the images & mention the column name on the top of the column where picture needs to be inserted that means if image names are in column "A" then Mention "A" on the top of the Column B where pictures will be inserted. & press Ctrl+L to auto insert the images.

Please Get my file which is attached here & work Once again. The only problem with my code is that it re sizes the picture to fit in the active cell i.e. Column "B" in Excel 2003 & didn't work same in Excel 2007.

[pradeep.05]

I Have attached one file for your reference to clear the working of the code.

[Kenneth Hobs]

I did not bother modifying your code as you only wanted image resizing.

I gave you a routine that you can easily implement. As I said, it does not do exactly what you wanted.

If you really want to force the dimensions, then use something like this. I leave it to you to add the offsets if you want that pseudo-border of whitespace. Notice that the main differences are: setting ShapeRange, LockAspectRatio, and use of RowHeight.

Sub ken2()
Dim pic As Object, r As Range, fPath As String

fPath = "x:\pics\"
Set pic = ActiveSheet.Pictures.Insert(fPath & Range("A2").Value2 & ".jpg")
Set r = Range("C10")
With pic
.Top = r.Top
.Left = r.Left
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = r.RowHeight
.ShapeRange.Width = r.Width
.ShapeRange.Rotation = 0#
End With
End Sub

For some reason, post #2 did not paste right. Replace the last line "with pic" with:

Not_Shape:
End Sub

[pradeep.05]

Dear Sir,

To be Very Frank, I don't know the VBA coding, This code was being developed by a colleague since long back & the guy is not working with us & even I don't have a contact of him. Therefore I came to the forum asking for help. All the processes mentioned in the code working with office 2003 but with 2007 the images are inserted but not fitting to the cell. I will give you the two files one with 2003 & another with 2007. Just modify the code shared by me & let me use the same. Kindly Compare the Two files New Microsoft Worksheet & Bracelet. You will know the difference.

[pradeep.05]

Dear Ken Sir,

Can u help me out, please!! or anyone else from your forum can help. Let me know.

[pradeep.05]

Can U provide me completely new code which works similar to this in all manner. I shall be thankful to you all.

[pradeep.05]

Can Anybody help it Out Please.

[Kenneth Hobs]

Did you want it for the last file? That would be different than the other.

Please explain in words what you want the macro to do. e.g. Press a key combination to insert the picture from y:\kens\pics with the base filename in column B for the current row and append the file extenstion of .jpg. Say cursor is in row 2. B2="ken". In D2, insert the picture file y:\kens\pics\ken.jpg and resize to fit in D2.

Case 2: Run the macro as above but insert all pics from B2 to the last row in B to column D.

Case 3: Only run the macro when B2 to the last row of B as a value changed. In this case, one might need the macro to delete the picture from D column first.

[pradeep.05]

Case 2 is the write choice.

[Kenneth Hobs]

Merging what you first posted, my code from post 5, and your latest goals:

Sub Jebs2()
Dim fso As Object, drv As Object
Dim fp As String, fpJPG, fpBMP
Dim c As Range, r As Range
Dim pic As Object

On Error GoTo errhandler

Set fso = CreateObject("Scripting.Filesystemobject")
Set drv = fso.GetDrive(fso.GetDriveName("j:"))

'If drv.serialnumber <> -1871811936 Then
'MsgBox "Unauthorised copy of Picture Insert or you may have changed your disk drives"
' Exit Sub
'End If

If Not fso.driveexists("j:\") Then
MsgBox "j: Not Exists Or Not Enabled", vbExclamation
Exit Sub
End If

fp = "J:\facet photos\"

Set r = Range("B2", Range("B" & Rows.Count).End(xlUp).Offset(-1)) '-1 to skip summing at end row
For Each c In r
fpJPG = fp & Replace(c.Value2, " ", "") & ".jpg"
fpBMP = fp & Replace(c.Value2, " ", "") & ".bmp"
Select Case True
Case fso.fileexists(fpJPG)
Set pic = ActiveSheet.Pictures.Insert(fpJPG)
Case fso.fileexists(fpBMP)
Set pic = ActiveSheet.Pictures.Insert(fpBMP)
Case Else
End Select

Set c = c.Offset(, 2) 'Set cell to move pic to, column D
With pic
.Top = c.Top
.Left = c.Left
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = c.RowHeight
.ShapeRange.Width = c.Width
.ShapeRange.Rotation = 0#
End With
Next c

Exit Sub
errhandler:
If Err.Number = 1004 Then
MsgBox "File with this Design No not found", vbInformation
Else
MsgBox Err.Description
End If
End Sub

[pradeep.05]

Dear Sir,

Thanks for the help. Now it seems it has reached the required goals BUT there are few problems still there. 1. if the starting picture doesn't exists in the root directory then it gives the error "Object variable or with block variable not set" and then other pictures which are there in the directory are also not inserted. Also it is behaving strangely for the file name which are in between and there is no image in the folder for the same suppose a file name mentioned on serial number 5 has no image in the directory but serial number 4 has then it is getting picture of serial number 4 in this place of serial number 5 which should be blank as it has no image.

2. Last file name picture is not inserted. 3. Pictures are inserted in column D instead they should be inserted in column C beside B. Kindly fix these & we are finished.

[Kenneth Hobs]

Before Next c

Nextc:
After Case Else:

Set c = c.Offset(, 1) 'Set cell to move pic to, column D
Goto Nextc


Change the offset from:

Set c = c.Offset(, 2) 'Set cell to move pic to, column D
to

Set c = c.Offset(, 1) 'Set cell to move pic to, column D

[pradeep.05]

Dear Sir,

Thank you very much, it's completed 99 percent. Only one percent left now. Image for the last name in Column "B" is not inserted still. That's it. Please fix this & we are done.

[Kenneth Hobs]

That is because one of your examples needed that.
Change

Set r = Range("B2", Range("B" & Rows.Count).End(xlUp).Offset(-1)) '-1 to skip summing at end row
to

Set r = Range("B2", Range("B" & Rows.Count).End(xlUp)

[pradeep.05]

Dear Sir,

Finally the goal has been achieved. Thanks for all your efforts & support. I have a last request that the macro is not working properly for merged cells. It means when a excel has Merged & normal cells both then it is inserting picture with reference to normal cell & not the merged one & the picture quality becomes blurred. Please go through the attachment for better explanation. Hope this time also you will give your kind support to finish this project off. Regards.

[Kenneth Hobs]

What is the password for the VBAProject?

[pradeep.05]

The VBA project attached with that file is different. Here is the Code for auto picture insert (for excel 2007) which u have finalized.


Sub Jebs2()
Dim fso As Object, drv As Object
Dim fp As String, fpJPG, fpBMP
Dim c As Range, r As Range
Dim pic As Object

On Error GoTo errhandler

Set fso = CreateObject("Scripting.Filesystemobject")
Set drv = fso.GetDrive(fso.GetDriveName("j:"))

'If drv.serialnumber <> -1871811936 Then
'MsgBox "Unauthorised copy of Picture Insert or you may have changed your disk drives"
' Exit Sub
'End If

If Not fso.driveexists("j:\") Then
MsgBox "j: Not Exists Or Not Enabled", vbExclamation
Exit Sub
End If

fp = "J:\Design Photography\"

Set r = Range("B2", Range("B" & Rows.Count).End(xlUp))

For Each c In r
fpJPG = fp & Replace(c.Value2, " ", "") & ".jpg"
fpBMP = fp & Replace(c.Value2, " ", "") & ".bmp"
Select Case True
Case fso.fileexists(fpJPG)
Set pic = ActiveSheet.Pictures.Insert(fpJPG)
Case fso.fileexists(fpBMP)
Set pic = ActiveSheet.Pictures.Insert(fpBMP)
Case Else
Set c = c.Offset(, 1) 'Set cell to move pic to, column C[/COLOR]
GoTo Nextc


End Select
Set c = c.Offset(, 1) 'Set cell to move pic to, column C
With pic
.Top = c.Top
.Left = c.Left
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = c.RowHeight
.ShapeRange.Width = c.Width
.ShapeRange.Rotation = 0#
End With
Nextc:
Next c

Exit Sub
errhandler:
If Err.Number = 1004 Then
MsgBox "File with this Design No not found", vbInformation
Else
MsgBox Err.Description
End If
End Sub

[pradeep.05]

Dear Sir,

The Macro given in the last post is not working for merged cells. It means when a excel has Merged & normal cells both then it is inserting picture with reference to normal cell & not the merged one. Please help. This is the last modification in this project . Will be quit after this. Kindly help.

[Kenneth Hobs]

Merge cells tend to be the bane to coders and as you can see, involves more work.

I don't have time to fit this to your file just now.

Like post 5, this shows how to do it.

Sub ken2_MergeCells()
Dim pic As Object, r As Range, fPath As String

fPath = "x:\pics\"
Set pic = ActiveSheet.Pictures.Insert(fPath & Range("B10").Value2 & ".jpg")
Set r = Range("C10").MergeArea

With pic
.Top = r.Top
.Left = r.Left
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = r.Rows.Height
.ShapeRange.Width = r.Columns.Width
.ShapeRange.Rotation = 0#
End With
End Sub

[pradeep.05]

Dear Sir,

Let me know where to fit this part of macro in original project OR please if possible you finish this off as soon as you get the time because this is the last request.

Regards,
Pradeep

[Kenneth Hobs]

I don't know what you mean by original project. For the code in your post #19, likely just 3 lines of code need to be modified. Those lines have a Ken comment before them.


Sub Jebs2()
Dim fso As Object, drv As Object
Dim fp As String, fpJPG, fpBMP
Dim c As Range, r As Range
Dim pic As Object

On Error GoTo errhandler

Set fso = CreateObject("Scripting.Filesystemobject")
Set drv = fso.GetDrive(fso.GetDriveName("j:"))

'If drv.serialnumber <> -1871811936 Then
'MsgBox "Unauthorised copy of Picture Insert or you may have changed your disk drives"
' Exit Sub
'End If

If Not fso.driveexists("j:\") Then
MsgBox "j: Not Exists Or Not Enabled", vbExclamation
Exit Sub
End If

fp = "J:\Design Photography\"

Set r = Range("B2", Range("B" & Rows.Count).End(xlUp))

For Each c In r
fpJPG = fp & Replace(c.Value2, " ", "") & ".jpg"
fpBMP = fp & Replace(c.Value2, " ", "") & ".bmp"
Select Case True
Case fso.fileexists(fpJPG)
Set pic = ActiveSheet.Pictures.Insert(fpJPG)
Case fso.fileexists(fpBMP)
Set pic = ActiveSheet.Pictures.Insert(fpBMP)
Case Else
Set c = c.Offset(, 1) 'Set cell to move pic to, column C[/COLOR]
GoTo Nextc


End Select
'Ken1
Set c = c.Offset(, 1).MergeArea 'Set cell to move pic to, column C
With pic
.Top = c.Top
.Left = c.Left
.ShapeRange.LockAspectRatio = msoFalse
'Ken2
.ShapeRange.Height = c.Rows.Height
'Ken3
.ShapeRange.Width = c.Columns.Width
.ShapeRange.Rotation = 0#
End With
Nextc:
Next c

Exit Sub
errhandler:
If Err.Number = 1004 Then
MsgBox "File with this Design No not found", vbInformation
Else
MsgBox Err.Description
End If
End Sub

[pradeep.05]

Dear Sir,

All Done. Thanks for kind support. It wouldn't have been possible without your help. Hope that u will help us in future also whenever required. Thanks again.

Regards,
Pradeep

[pradeep.05]

Dear Sir,

Just one question Post #24 is the final code. With this code i can insert pictures in column C for the pictures names in column B. That means in Post # 24 code it is fixed that one should have file names in column B & then picture will be inserted in column C.

What happens if the file name is any column suppose column D & i want to insert picture next to that column Suppose column E. The code will change completely or a little change & it will work. If a few changes are there please let me know it can be done or not & if there are too many changes then let the post #24 be the final code.

Thanks & Regards,

Pradeep

[Kenneth Hobs]

Change this to where your picture name cells are at.

Set r = Range("B2", Range("B" & Rows.Count).End(xlUp))
Change this to where you want your pictures inserted. As is now, it offsets 1 column to the right of the column in that above.

Set c = c.Offset(, 1).MergeArea 'Set cell to move pic to, column C