Consulting

Page 1 of 2 1 2 LastLast
Results 1 to 20 of 26

Thread: Auto Picture Insert in Excel 2007

  1. #1

    Auto Picture Insert in Excel 2007

    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
    Attached Files Attached Files
    Last edited by Aussiebear; 10-10-2015 at 02:52 AM. Reason: Added code tags

  2. #2
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,962
    Location
    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

  3. #3
    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.

  4. #4
    I Have attached one file for your reference to clear the working of the code.
    Attached Files Attached Files

  5. #5
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,962
    Location
    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
    Last edited by Kenneth Hobs; 08-12-2015 at 07:11 AM.

  6. #6
    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.
    Attached Files Attached Files

  7. #7
    Dear Ken Sir,

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

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

  9. #9
    Can Anybody help it Out Please.

  10. #10
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,962
    Location
    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.

  11. #11
    Case 2 is the write choice.

  12. #12
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,962
    Location
    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

  13. #13
    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.

  14. #14
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,962
    Location
    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

  15. #15
    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.

  16. #16
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,962
    Location
    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)

  17. #17

    Auto Picture insert in 2007

    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.
    Attached Files Attached Files

  18. #18
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,962
    Location
    What is the password for the VBAProject?

  19. #19
    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
    Last edited by Aussiebear; 10-10-2015 at 02:55 AM. Reason: added code tags

  20. #20
    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.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •