Insert embed pictures to excell file bsed on cell value

[mellowdeep]

Hello there i have a excell addin thats importing pictures based on cell value.
The addin got 4 userforms
-selecting cell where the picture will be inserted.
-selecting the article value
-selecting the first and the last row
-selecting the folder where pictures are located.

The problem is that imported pictures are not saved with file so i want to save the pictures and send them by mail.
here is the addin code

Sub ResimGetir()
UserForm1.Show (0)
End Sub

Sub ResimAyarla()

ResimSutun = Mid(Selection.Address, 2, 1)
If ResimSutun = "" Then End

ResimYukseklik = Selection.RowHeight
ResimGenislik = Selection.ColumnWidth

     
End Sub

Sub ResimAyarla2()

ArticleSutun = Mid(Selection.Address, 2, 1)
If ArticleSutun = "" Then End

End Sub

Sub ResimAyarla3()


ilkSatir = UserForm3.TextBox1
If ilkSatir = "0" Or ilkSatir = "" Then End

SonSatir = UserForm3.TextBox2
If SonSatir = "0" Or SonSatir = "" Then End

End Sub

Sub ResimAyarla4Default()
FolderName = ActiveWorkbook.Path & "\Images"
ResimAyarla5
End Sub

Sub ResimAyarla4Folderli()
FolderName = BrowseForFolder
ResimAyarla5
End Sub

Sub ResimAyarla5()

Range(ResimSutun & ilkSatir & ":" & ResimSutun & SonSatir).Select
Selection.RowHeight = ResimYukseklik

Range(ArticleSutun & ilkSatir).Select

Do

ilkAdr = Selection.Address
Adres1 = Right(ilkAdr, Len(ilkAdr) - 3)
On Error Resume Next
ImageName = Range(ArticleSutun & Adres1).Value

Select Case Len(ImageName)

Case 1
    ImageName = "00000" & ImageName
Case 2
    ImageName = "0000" & ImageName
Case 3
    ImageName = "000" & ImageName
Case 4
    ImageName = "00" & ImageName
Case 5
    ImageName = "0" & ImageName

End Select

Range(ResimSutun & Adres1).Select

Application.ActiveSheet.Pictures.Insert(FolderName & "\" & ImageName & ".jpg").Select

If Selection.Width > Selection.Height Then Olcek = Selection.Width Else Olcek = Selection.Height

Selection.ShapeRange.IncrementLeft 3.75
Selection.ShapeRange.IncrementTop 2.25
Selection.ShapeRange.ScaleWidth (ResimYukseklik * 0.9 / Olcek), msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight (ResimYukseklik * 0.9 / Olcek), msoFalse, msoScaleFromTopLeft

Range(ResimSutun & Adres1 + 1).Select
Loop Until Adres1 = SonSatir
End If
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
    
    Dim ShellApp As Object
     
    Set ShellApp = CreateObject("Shell.Application"). _
    BrowseForFolder(0, "Please select a Folder", 0, OpenAt)
     
    On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
    On Error GoTo 0
     
    Set ShellApp = Nothing
     
    Select Case Mid(BrowseForFolder, 2, 1)
    Case Is = ":"
        If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
    Case Is = "\"
        If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
    Case Else
        GoTo Invalid
    End Select
     
    Exit Function
     
Invalid:
    BrowseForFolder = False
End Function

I tryed changing the insert with

ActiveSheet.Shapes.AddPicture(Filename:=FolderName & "\" & ImageName & ".jpg", _
 linktofile:=fail, savewithdocument:=True, Left:=1, Top:=1, Width:=30, Height:=60).Select

The problem here is that all the pictures are added not in the range cells but in the top left angle of the sheet.
How to set the pictures to be added where i want to?

regards
Anton

 

[pgc01]

Hi Anton
Welcome to the board

...The problem is that imported pictures are not saved with file so i want to save the pictures and send them by mail. ...

Well, the Pictures.Insert() method does not embed the picture file in the workbook.

You can however still do it, if you insert the pictures using the AddPicture() method of the Shapes object. You can specify that you want no link and to store a copy of the picture in the workbook.

This means that you don't need to make copies of the pictures and send them by email.

The other problem: you did not specify where you want the pictures in the Pictures.Insert() command.

Check the help for the AddPictures() method of the Shapes object and see if it solves your problem.

 

[mellowdeep]

Hello PGC, and thanks for the resposce.

The add in works great. Its inserting pictrures in every cell in the range i select. Its working like that ArticleSutun is where value is placed and ResimSutun is where the picture for that value is placed.
Ilksatir and sonsatir is the range for the pictures. Like Steve Jobs was saying it just works. But only with linked images.
When changing the insert command with shape.addpicture its adding right pictures in wrong places.

I tryed changing some things but its only add 1 picture and looks like its not reseting

Range(ResimSutun & ilkSatir & ":" & ResimSutun & SonSatir).Select
Selection.RowHeight = ResimYukseklik

Range(ArticleSutun & ilkSatir).Select

Do

ilkAdr = Selection.Address
Adres1 = Right(ilkAdr, Len(ilkAdr) - 3)
On Error Resume Next
Imagename = Range(ArticleSutun & Adres1).Value

Select Case Len(Imagename)

Case 1
    Imagename = "00000" & Imagename
Case 2
    Imagename = "0000" & Imagename
Case 3
    Imagename = "000" & Imagename
Case 4
    Imagename = "00" & Imagename
Case 5
    Imagename = "0" & Imagename

End Select
mypiclis = FolderName & "\" & Imagename & ".jpg"
rng = Range("ArticleSutun", _
   Range("ArticleSutun").End(xlDown))
rng.Select
For Each cell In rng
Set Shape = ActiveSheet.Shape.AddPicture(mypiclis, False, True, Left:=1, Top:=1, Width:=15, Height:=25)
Next
Range(ResimSutun & Adres1 + 1).Select
Loop Until Adres1 = SonSatir

 

[pgc01]

Hi

When changing the insert command with shape.addpicture its adding right pictures in wrong places.

In the code you posted I see that you insert all the pictures at the top left corner of the worksheet.
Where is the code where you set their position?
Also, why not inserting them directly where you want them?

Please clarify.

 

[pgc01]

P. S. I'll be out for the rest of the day and so this is a small test that maybe will help you

I changed the size of cell D4 to the size that I want the picture to have.

This code imports a picture so that in superposes D4 and gives it a name.

Sub test()
Dim r As Range
Dim shp As Shape
Dim sPath As String

sPath = "c:\tmp\pic1.jpg" ' path of the image file
Set r = Range("D4") ' the picture will be superposed over this cell

With r
    Set shp = ActiveSheet.Shapes.AddPicture(sPath, False, True, .Left, .Top, .Width, .Height)
    shp.Name = "My picture"
End With

End Sub

Maybe you can adapt this.

 

[mellowdeep]

Thanks for the help. I found a solution.

here is the code and its working great
maybe there are useless thing inside it because im not that in to it but its ok for now.

Dim Response As Integer
Dim MyPic As String
Dim rng As Range
Dim shp As Shape
Dim rng1 As Range
 
Response = MsgBox("Keep Pictures inside the file? Warning, file will get bigger!", vbYesNo + vbQuestion, "Keep Pictures")
 
If Response = vbYes Then
Range(ArticleSutun & ilkSatir).Select
Do
ilkadr = Selection.Address
adres1 = Right(ilkadr, Len(ilkadr) - 3)
On Error Resume Next
imagename = Range(ArticleSutun & adres1).Value
 
Select Case Len(imagename)
 
Case 1
    imagename = "00000" & imagename
Case 2
    imagename = "0000" & imagename
Case 3
    imagename = "000" & imagename
Case 4
    imagename = "00" & imagename
Case 5
    imagename = "0" & imagename
 
End Select
 
 
MyPic = FolderName & "\" & imagename & ".jpg"
Range(ResimSutun & adres1).Select
xColIndex = Application.ActiveCell.Column
xRowIndex = Application.ActiveCell.Row
Set rng1 = Cells(xRowIndex, xColIndex)
Set shp = ActiveSheet.Shapes.AddPicture(MyPic, False, True, rng1.Left, rng1.Top, rng1.Width, rng1.Height)
Range(ResimSutun & adres1 + 1).Select
Loop Until adres1 = SonSatir
 
else

 

[pgc01]

You're welcome. Thanks for the feedback.