Auto Picture Insert in Excel 2007

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.

Code:

---

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

---

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

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.

Code:

---

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

---

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

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

Change this to where your picture name cells are at.

Code:

---

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.

Code:

---

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

---