PDA

View Full Version : Issue with pictures upload using vba code into excel- they disapear



RuxandraIlie
06-24-2014, 05:51 AM
Dear All,

I address this mail towards anybody that may offer his/her support in solving the below issue:

1.I have a vba code that helps me upload pictures from my computer to an excel file
2.I am using Excel 2010
3.If I use the standard pictures of Windows itself and I send the file to other computers, the file keeps the pictures
3.If I upload different pictures ( my personal ones) and send the file to other computers, it losses the pictures and provide an error :"The linked image can not be displayed. The file may have been removed, deleted. Verify that the link points to the correct file and location"
the code is the following one:

Private Sub CommandButton1_Click()
Dim oShape As Shape
For Each oShape In ActiveSheet.Shapes
If Not Application.Intersect(oShape.TopLeftCell, ActiveSheet.Range("M8:U25")) Is Nothing Then
oShape.Delete
End If
Next


Dim PicRange As Range
Set PicRange = Range("M8:U25")
PicRange.Clear
someFileName = Application.GetOpenFilename()
If someFileName <> False Then
ActiveSheet.Pictures.Insert(someFileName).Select
With Selection
.ShapeRange.LockAspectRatio = msoFalse
.Left = PicRange.Left
.Top = PicRange.Top
.Width = PicRange.Width
.Height = PicRange.Height
End With
End If
End Sub

I am a little bit desperate as tomorrow I need to present an application and just today I discovered the bug.
Does anybody have a solution?
Thank you so much in advance and I really appreciate any idea,
Ruxandra

Kenneth Hobs
06-24-2014, 11:44 AM
Private Sub CommandButton1_Click()
Dim oShape As Shape
Dim PicRange As Range
Dim someFileName As Variant

For Each oShape In ActiveSheet.Shapes
If Not Application.Intersect(oShape.TopLeftCell, ActiveSheet.Range("M8:U25")) Is Nothing Then
oShape.Delete
End If
Next oShape

Set PicRange = Range("M8:U25")
PicRange.Clear
someFileName = Application.GetOpenFilename()
If someFileName <> False Then
'With ActiveSheet.Pictures.Insert(someFileName)
With PicRange
Sheet1.Shapes.AddPicture someFileName, msoFalse, msoTrue, .Left, .Top, .Width, .Height
'.ShapeRange.LockAspectRatio = msoFalse
'.Left = PicRange.Left
'.Top = PicRange.Top
'.Width = PicRange.Width
'.Height = PicRange.Height
End With
End If
End Sub