VBA image paste (not Link)

[ponch]

Hi again gang,
Below is a piece of code that I wrangled together for the specific purpose of inserting product images into any spreadsheet where

1. the product number is in column "c"
2. Product image library contains thumbnail images with a file name equal to the product number (saved in \\Myservername\Accounting\Kurt\John\Projects\Thumbnail)

Sub AddStyleNumberPic()
Dim MyPictureFile As String
Dim MyCell As Range
Dim counter As Integer
counter = 15
Do While ActiveSheet.Range("e" & counter) <> 0
If ActiveSheet.Range("c" & counter) <> 0 Then
namedcell = ActiveSheet.Range("C" & counter).Value
If FileFolderExists("\\Myservername\Accounting\Kurt\John\Projects\Thumbnail image excel mouseover\S09publisherjpgs\" & namedcell & ".jpg") Then
MyPictureFile = "\\Myservername\Accounting\Kurt\John\Projects\Thumbnail image excel mouseover\S09publisherjpgs\" & namedcell & ".jpg"
With ActiveSheet
Set MyCell = .Range("A" & counter)
.Pictures.Insert(MyPictureFile).Select
'---------------------------------------------------------------------
With MyCell
Selection.Top = .Top
Selection.Left = .Left
Selection.Width = .Width
Selection.Height = .Height
Selection.Placement = xlMoveAndSize ' move and size with cells
Selection.PrintObject = True
'-------------------------------------------------------------
'Selection.ShapeRange.PictureFormat.Brightness = 0.5 ' various formats available
'-------------------------------------------------------------
'-
.Select ' change focus (selection) from picture to cell
End With
'---------------------------------------------------------------------
End With
Else

With ActiveSheet
.Range("a" & counter) = "Picture N/A"
End With
End If

End If
counter = counter + 1
Loop

End Sub

Public Function FileFolderExists(strFullPath As String) As Boolean
'Macro Purpose: Check if a file or folder exists
On Error GoTo EarlyExit
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True

EarlyExit:
On Error GoTo 0
End Function


It works, but the images are linked to the network path. This is a problem because I want to be able to send the files (with images) to customers outside my network.

How can I embed the images in the sheet so that it can be shared?

John

 

[ogo]

HI TRY THIS NOW,

Sub AddStyleNumberPic()
 
Dim MyPictureFile As String
Dim MyCell As Range
Dim counter As Integer

counter = 15
Do While ActiveSheet.Range("e" & counter) <> 0
If ActiveSheet.Range("c" & counter) <> 0 Then
namedcell = ActiveSheet.Range("C" & counter).Value
If FileFolderExists("[URL="file://\\Myservername\Accounting\Kurt\John\Projects\Thumbnail"]\\Myservername\Accounting\Kurt\John\Projects\Thumbnail[/URL] image excel mouseover\S09publisherjpgs\" & namedcell & ".jpg") Then
MyPictureFile = "[URL="file://\\Myservername\Accounting\Kurt\John\Projects\Thumbnail"]\\Myservername\Accounting\Kurt\John\Projects\Thumbnail[/URL] image excel mouseover\S09publisherjpgs\" & namedcell & ".jpg"
With ActiveSheet
Set MyCell = .Range("A" & counter)
    ActiveSheet.Pictures.Insert(MyPictureFile).Select
    Selection.ShapeRange.ScaleWidth 0.42, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.42, msoFalse, msoScaleFromTopLeft
    Application.CommandBars("Picture").Visible = False
    ActiveWindow.SmallScroll Down:=-9
    
'---------------------------------------------------------------------
With MyCell
Selection.Top = .Top
Selection.Left = .Left
Selection.Width = .Width
Selection.Height = .Height
Selection.Placement = xlMoveAndSize ' move and size with cells
Selection.PrintObject = True
'-------------------------------------------------------------
'Selection.ShapeRange.PictureFormat.Brightness = 0.5 ' various formats available
'-------------------------------------------------------------
'-
.Select ' change focus (selection) from picture to cell
End With
'---------------------------------------------------------------------
End With
Else
With ActiveSheet
.Range("a" & counter) = "Picture N/A"
End With
End If
End If
counter = counter + 1
Loop
End Sub
Public Function FileFolderExists(strFullPath As String) As Boolean
'Macro Purpose: Check if a file or folder exists
On Error GoTo EarlyExit
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
On Error GoTo 0

End Function

 

[ponch]

woo hoo,

Thanks for that. Just what the doctor orderred.
It's so easy, once you know how.

 

[ogo]

Always happy to help

 

[ponch]

Hi,
I just got a surprise. The images populate the sheet nicely, but when I send it to anyone outside my LAN (ie. where the images are saved), they don't see the images, instead they get a message that says "the linked image can not be displayed. Varify the image has not been moved, renamed or deleted...."

I'll paste my code in case I've made a dumb mistake.

Help please!


Sub AddStyleNumberPic()

Dim MyPictureFile As String
Dim MyCell As Range
Dim counter As Integer
counter = 15
Do While ActiveSheet.Range("h" & counter) <> 0
If ActiveSheet.Range("f" & counter) <> 0 Then
namedcell = ActiveSheet.Range("F" & counter).Value
If FileFolderExists("\\1075-server-002\Design\Thumbnail_ prod_ image_ library\" & namedcell & ".jpg") Then
MyPictureFile = "\\1075-server-002\Design\Thumbnail_ prod_ image_ library\" & namedcell & ".jpg"
With ActiveSheet
Set MyCell = .Range("A" & counter)
ActiveSheet.Pictures.Insert(MyPictureFile).Select
Selection.ShapeRange.ScaleWidth 0.42, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 0.42, msoFalse, msoScaleFromTopLeft
Application.CommandBars("Picture").Visible = False
ActiveWindow.SmallScroll Down:=-9

'---------------------------------------------------------------------
With MyCell
Selection.Top = .Top
Selection.Left = .Left
Selection.Width = .Width
Selection.Height = .Height
Selection.Placement = xlMoveAndSize ' move and size with cells
Selection.PrintObject = True
'-------------------------------------------------------------
'Selection.ShapeRange.PictureFormat.Brightness = 0.5 ' various formats available
'-------------------------------------------------------------
'-
.Select ' change focus (selection) from picture to cell
End With
'---------------------------------------------------------------------
End With
Else
With ActiveSheet
.Range("a" & counter) = "Picture N/A"
End With
End If
End If
counter = counter + 1
Loop
End Sub
Public Function FileFolderExists(strFullPath As String) As Boolean
'Macro Purpose: Check if a file or folder exists
On Error GoTo EarlyExit
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
On Error GoTo 0
End Function

 

[Tele720]

I have the same problem and unfortunately no answer. My macro worked fine in Excel 2003 and never linked the pictures, but now the images become linked for some reason.

I hope someone has a solution. Thanks in advance!