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.