Vba Excel - 添加图片

Question

您好我已经创建了一个代码，可以将图像插入Excel，但不幸的是，图像作为图像文件的链接插入到本地目录。下面是完整的代码和我卡住的行

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

完整的代码是

Sub InsertOfficePic()
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
''''''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