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.