Excel VBA Course
Excel VBA Course - From Beginner to Expert

200+ Video Lessons
50+ Hours of Video
200+ Excel Guides

Become a master of VBA and Macros in Excel and learn how to automate all of your tasks in Excel with this online course. (No VBA experience required.)

View Course

Image insert from cell

0

Hello,

in module Empl_Misc: Equip_LoadPic

Want to show all image in the current cells from the location

There are received from.

But it don't load all images.

Sub Equip_LoadPic()
Dim SelRow As Long, EquipRow As Long
Dim PicPath As String
With Sheet11
On Error Resume Next
.Shapes("EquipPic").Delete
On Error GoTo 0
 If .Range("B3").value = Empty Then Exit Sub 'Tempory cell
    SelRow = .Range("B3").value 'Selected Row
    EquipRow = .Range("O" & SelRow).value 'Equipment Row
    
    On Error Resume Next
    PicPath = Sheet12.Range("P" & EquipRow).value 'Picture Path
    If Dir(PicPath, vbDirectory) <> "" Then 'Picture Path Exists
        ActiveSheet.Pictures.Insert(PicPath).Select
        With Selection.ShapeRange
                .LockAspectRatio = msoFalse
                .Left = Sheet11.Range("L" & SelRow).Left
                .Top = Sheet11.Range("L" & SelRow).Top
                .Width = Sheet11.Range("L" & SelRow).Width
                .Height = Sheet11.Range("L" & SelRow).Height
                .Name = "EquipPic"
        End With
    End If
End With
End Sub

Any help please

Workbook added

Answer
Discuss

Discussion

Ghost (? I have no idea what to call you!)

It's getting hard to follow your code changes when you have no version control on your workbooks (each called MyWorkbook updated) and this one that the G2 selection problem which (unfixed) causes a crash for me. 

You're calling up images we don't have (or need to create) so they don't load without extra effort for us. 

Two minor points-  both your Worksheet Change subs turns off Application Screen updating initially but have no statement to restore that (I know it should return after the subs exit) but it may hinder debugging (if crashes occur) and it's better to enanble explicitly.

Also you changed the code below but it should have read msoTrue not msoCTrue, right?
.Visible = msoCTrue
John_Ru (rep: 6092) Nov 29, '20 at 9:42 am
Hi John_Ru,

Sorry to hear that, weird mine don't crash
But i will update the file in a sec and upload it under the other file

If you can give me an idea how i can solved the picture location issue
Maybe you can load the image then?
Let me know before i upload the new workbook
Thanks
GhostofWanted (rep: 46) Nov 29, '20 at 10:18 am
Add to Discussion

Answers

0
Selected Answer

Hi again.

Your attached file removed so in my version (attached) you'll need to change CustomerItems cells D4:D6 to locations with your test image files (since I changed them so I could test). I've corrected the G2 selection issue however (as per separate question). 

In the Equip_LoadPic() sub, I think there are two problems: you use SelRow to pick up the pre-written image path from CustomerItems but it can refer to an emply cell (e.g. P6 for Sylv, Floye). I think it should read D (not L).

Also you set the picture height to acell height- it could be squashed so I commented that out. These are changed in bold below and in the attached file:

PicPath = Sheet12.Range("D" & EquipRow).value 'Picture Path '### was L not D
    If Dir(PicPath, vbDirectory) <> "" Then 'Picture Path Exists
        'With .Pictures.Insert(PicPath)
           ' With .ShapeRange
           '     .LockAspectRatio = msoTrue
           '     .Height = 150
           '     .Name = "EquipPic"
           ' End With
        ActiveSheet.Pictures.Insert(PicPath).Select
        With Selection.ShapeRange
                .LockAspectRatio = msoFalse
                .Left = Sheet11.Range("L" & SelRow).Left
                .Top = Sheet11.Range("L" & SelRow).Top
                .Width = Sheet11.Range("L" & SelRow).Width
                '.Height = Sheet11.Range("L" & SelRow).Height' ### don't use cell height or image is squashed into a cell
        End With

Also, you mentioned before multiple images- I haven't seen (in the time I had) where you delete images from a previous selection in G2.

REVISION 1: In the second file attached (Myworkbook Picture Issue v0_a.xlsm) based on your recent revision, apart from the chnages above, columns A:B  in TESTMAIN2 are unhidden and my test file locations appear in CustmerItems(please change)

in Worksheet_SelectionChange I've reinstated the line:

    If Range("O" & Target.row).value <> "" Then Equip_LoadPic

In Equip_LoadPic, I've made a minor change so the shapes don't have the some name.

With Selection.ShapeRange
          ..
                '.Height = Sheet11.Range("L" & SelRow).Height
                .Name = "EquipPic" & SelRow 'don't call shapes the same thing!
        End With

Now, for the case of "Mike, Floye" two images are loaded (but the second image aligned with cell L11 is hidden by that in cell L10. If I click in row 11 of the table however, the second image is brought to the front and so visible. Not sure if that's what you want.

You still need to change your macros to delete the pictures loaded from previous G2 selections which have loaded images. 

Revision 2: Firstly I've corrected the renaming of shapes in the code I added above (I didn't spot that the double inverted comma was at the end of the line so the intended comment was part of the shape name!).

Now loaded images have unique names liked EmpPic10, EmpPic11 etc. so the (With Sheet11) .Shapes("EmpPic").Delete doesn't work, as you say. I've commented out that line in the sub Equip_LoadPic() and instead changed Sheet11 sub to include the bits in bold below (which cycle through shapes and delete any like EmpPic10, EmpPic11 etc.):

Private Sub Worksheet_Change(ByVal Target As Range)
'Application.ScreenUpdating = False
Dim EmpRow As Long, Sp As Shape
If Not Intersect(Target, Range("G2")) Is Nothing Then
    If Range("G2").value <> Empty And Range("B5").value <> Empty Then
        For Each Sp In Sheet11.Shapes
         If Sp.Name Like "EquipPic*" Then Sp.Delete
        Next Sp
    Empl_Load
    End If
End If
If Not Intersect(Target, Range("J2")) Is Nothing And Range("B5").value <> "" Then Order_Load
End Sub
This means that if G2 changes, the old images are deleted before any new images are loaded (this wasn't happening with the now-deleted delete statement in Equip_LoadPic if the G2 selection had no matching image files listed).

The new file should be okay now.

Discuss

Discussion

Hi John_Ru
I have added the file again
I did forget to update the lines you suggested, sorry
Hope you can find the solution :)

the multi images are with the customer Mike Floye
Has 2 images
But only 1 loads
Thank you
GhostofWanted (rep: 46) Nov 29, '20 at 11:25 am
Okay John_Ru
I have updated the file once again
And i hope i removed all the bad stuff
And replace them with yours
GhostofWanted (rep: 46) Nov 29, '20 at 11:53 am
Please see Revision 1 to my Answer
John_Ru (rep: 6092) Nov 29, '20 at 12:59 pm
Thanks for the updated code.
But no idea what we are doing wrong or even overlooking but the 2nd row of mike floye still does not show his picture. Only with the first comes the picture.
And no don't need to selected the rows for showing the image anymore :)
because we loading the images at once
But still no idea why its not working...
Maybe we try to do a lot in 1 day i don't know.
Even i was thinking maybe with a loop through the cells to load the images?
But we still learning and learning alot of you guys :)
GhostofWanted (rep: 46) Nov 29, '20 at 2:04 pm
Ghost(?)
I guess you tried my last file but with your images. If you saw my image file names, you may have noticed they were only "150x150" (pixels) and just plain blocks of colour so easy to see. If your images were bigger,  perhaps you could not see the second image for Mike, Floye. I got 2 images loaded, a black image overlaid on a white image. The latter was only obvious when I clicked on that row of the table (since you aligned them with adjacent cell edges).
Suggest you try smaller images or set the Height property to 150 or less (while keeping the aspect ratio) 
John_Ru (rep: 6092) Nov 29, '20 at 3:31 pm
Oh i see,
Sorry my mistake. 
yeah i removed that part so i put it back and yeah got all the images now
Sorry :)
Last question because you helped me alot today
How can i remove all the images when they have now 
.Name = "EquipPic" & EquipRow 

Because i used this part but they are not removing
Shapes("EquipPic").Delete
Thanks
GhostofWanted (rep: 46) Nov 29, '20 at 3:49 pm
See Revision 2 to my Answer please. 
John_Ru (rep: 6092) Nov 29, '20 at 5:13 pm
Oh thank you so much for your awesome help
Worked like a charm
You rock John_Ru ;)

Thanks alot
GhostofWanted (rep: 46) Nov 29, '20 at 5:20 pm
Add to Discussion


Answer the Question

You must create an account to use the forum. Create an Account or Login