Hi I have created a code that can insert an image to excel but unfortunately image inserted as link to the image file to the local directory. Below is the complete code and the line that Im stuck is
With rngLogo
Set pic = .Parent.Pictures.Insert(sFileToOpen)
pic.Top = .Top + 2.5 ' Customize const (2.5) as you need
'pic.Left = .Left
pic.ShapeRange.LockAspectRatio = msoTrue
pic.ShapeRange.Width = w
pic.ShapeRange.Rotation = 0#
pic.Locked = False
And the complete code is
Sub InsertOfficePic()
' Your Procedure modified
'--
Dim rngLogo As Range
Dim sFileToOpen
Dim pic As Object
Dim w, h As Long
Dim sngScale As Single
Dim MyPath As String, MyScript As String, MyFiles As String
'Const csSHEET_NAME As String = "Open House Sheet"
'Const csRANGE_NAME As String = "OfficeLogo"
''''''MAC''''''''
#If Mac Then
'Get the documents folder as a default
On Error Resume Next
MyPath = MacScript("return (path to documents folder) as String")
'Set up the Apple Script to look for text files
MyScript = "set applescript's text item delimiters to "","" " & vbNewLine & _
"set theFiles to (choose file of type " & " {""public.png"", ""public.jpg"", ""public.jpeg""} " & _
"with prompt ""Please select a file or files"" default location alias """ & _
MyPath & """ multiple selections allowed true) as string" & vbNewLine & _
"set applescript's text item delimiters to """" " & vbNewLine & _
"return theFiles"
'Run the Apple Script
sFileToOpen = MacScript(MyScript)
On Error GoTo 0
'If there are multiple files, split it into an array and return the results
If sFileToOpen = False Then Exit Sub
'''''MAC''''
#Else
sFileToOpen = Application.GetOpenFilename( _
"Picture Files,*.jpg;*.jpeg;*.bmp;*.png;*.tif;*.gif", _
Title:="Please select a Logo.")
If sFileToOpen = False Then Exit Sub
#End If
For Each ws In ThisWorkbook.Worksheets
If ws.Name = "Real Audience pie chart" Then
GoTo 10
End If
With ThisWorkbook.Worksheets(ws.Name)
.Activate ' optional
'Reference Picture Range
If ws.Name = "ROI Summary" Then
Set rngLogo = .Range("B4:J4")
Else
If ws.Name = "Intake Session" Then
Set rngLogo = .Range("B4:I4")
Else
If ws.Name = "Major GrowthMAP Session" Then
Set rngLogo = .Range("B4:I5")
Else
If ws.Name = "Closing Session" Then
Set rngLogo = .Range("B4:I5")
Else
If ws.Name = "Profit Analysis" Then
Set rngLogo = .Range("B4:H4")
End If
End If
End If
End If
End If
' Delete all previous pictures
For Each pic In .Pictures
'Here you can put deleting criteria, e.g.
'If pic.Name <>"YourPicture" Then
pic.Delete
Next pic
With rngLogo ' Is this Range Name = "OfficeLogo"?
h = .Height
w = .Width
End With
With rngLogo
Set pic = .Parent.Pictures.Insert(sFileToOpen)
pic.Top = .Top + 2.5 ' Customize const (2.5) as you need
'pic.Left = .Left
pic.ShapeRange.LockAspectRatio = msoTrue
pic.ShapeRange.Width = w
pic.ShapeRange.Rotation = 0#
pic.Locked = False
pic.Placement = xlFreeFloating
On Error Resume Next
' adjust Logo dimensions
If pic.Width < w And pic.Height < h Then
sngScale = 1.001
Do Until pic.Width >= w Or pic.Height >= h
pic.ShapeRange.ScaleWidth sngScale, msoFalse
pic.ShapeRange.ScaleHeight sngScale, msoFalse
sngScale = sngScale + 0.01
Loop
Else
sngScale = 0.999
Do Until pic.Width <= w And pic.Height <= h
pic.ShapeRange.ScaleWidth sngScale, msoFalse
pic.ShapeRange.ScaleHeight sngScale, msoFalse
sngScale = sngScale - 0.01
Loop
End If
pic.Left = rngLogo.Left + (w - pic.Width) / 2 + 1
End With
'pic.PrintObject = True
End With
10
Next
MsgBox "Logo Changed"
ThisWorkbook.Sheets(1).Activate
End Sub
Bookmarks