Excel 使用 shapes.AddPicture VBA 宏将 URL 中的图像添加到工作簿
Excel add image to workbook from URL using shapes.AddPicture VBA Macro
所以我有以下代码可以正常工作,并使用带有 URL 的列将图像添加到下一列。问题是,如果您将它发送给某人,它就会损坏。我想将其切换为 shapes.AddPicture,这样图片就会跟随电子表格。我找到了一些可行的方法,但它不会像下面的解决方案那样将图片添加到单个单元格中。
Sub URLPictureInsert()
Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
Set Rng = ActiveSheet.Range("T3:T25")
For Each cell In Rng
filenam = cell
ActiveSheet.Pictures.Insert(filenam).Select
Set Pshp = Selection.ShapeRange.Item(1)
If Pshp Is Nothing Then GoTo lab
xCol = cell.Column + 1
Set xRg = Cells(cell.Row, xCol)
With Pshp
.LockAspectRatio = msoFalse
.Width = 70
.Height = 100
.Top = xRg.Top + (xRg.Height - .Height) / 2
.Left = xRg.Left + (xRg.Width - .Width) / 2
End With
lab:
Set Pshp = Nothing
Range("T2").Select
Next
Application.ScreenUpdating = True
End Sub
这个有效,但它会在同一区域中将图像一个接一个地添加 - 我希望它能像上面的那样动态放置图像
Sub URLPhotoInsert()
Dim cShape As Shape
Dim cRange As Range
Dim cColumn As Long
On Error Resume Next
Application.ScreenUpdating = False
Set xRange = ActiveSheet.Range("j3:j4")
For Each cell In xRange
cName = cell
ActiveSheet.Shapes.AddPicture (cName), True, True, 100, 100, 70, 70
Set cShape = Selection.ShapeRange.Item(1)
If cShape Is Nothing Then GoTo line22
cColumn = cell.Column - 1
Set cRange = Cells(cell.Row, cColumn)
line22:
Set cShape = Nothing
Range("D5").Select
Next
Application.ScreenUpdating = True
End Sub
我终于找到了对我有用的东西 - 对于那些想要使用 URL 作为源
与文件一起存储图片的人
Option Explicit
Dim rng As Range
Dim cell As Range
Dim Filename As String
Sub URLPictureInsert()
Dim theShape As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
' Set to the range of cells you want to change to pictures
Set rng = ActiveSheet.Range("T1206:T1400")
For Each cell In rng
Filename = cell
' Use Shapes instead so that we can force it to save with the document
Set theShape = ActiveSheet.Shapes.AddPicture( _
Filename:=Filename, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, _
Left:=cell.Left, Top:=cell.Top, Width:=15, Height:=15)
If theShape Is Nothing Then GoTo isnill
With theShape
.LockAspectRatio = msoTrue
' Shape position and sizes stuck to cell shape
.Top = cell.Top + 1
.Left = cell.Left + 1
.Height = cell.Height - 2
.Width = cell.Width - 2
' Move with the cell (and size, though that is likely buggy)
.Placement = xlMoveAndSize
End With
' Get rid of the
cell.ClearContents
isnill:
Set theShape = Nothing
Range("D2").Select
Next
Application.ScreenUpdating = True
Debug.Print "Done " & Now
End Sub
所以我有以下代码可以正常工作,并使用带有 URL 的列将图像添加到下一列。问题是,如果您将它发送给某人,它就会损坏。我想将其切换为 shapes.AddPicture,这样图片就会跟随电子表格。我找到了一些可行的方法,但它不会像下面的解决方案那样将图片添加到单个单元格中。
Sub URLPictureInsert()
Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
Set Rng = ActiveSheet.Range("T3:T25")
For Each cell In Rng
filenam = cell
ActiveSheet.Pictures.Insert(filenam).Select
Set Pshp = Selection.ShapeRange.Item(1)
If Pshp Is Nothing Then GoTo lab
xCol = cell.Column + 1
Set xRg = Cells(cell.Row, xCol)
With Pshp
.LockAspectRatio = msoFalse
.Width = 70
.Height = 100
.Top = xRg.Top + (xRg.Height - .Height) / 2
.Left = xRg.Left + (xRg.Width - .Width) / 2
End With
lab:
Set Pshp = Nothing
Range("T2").Select
Next
Application.ScreenUpdating = True
End Sub
这个有效,但它会在同一区域中将图像一个接一个地添加 - 我希望它能像上面的那样动态放置图像
Sub URLPhotoInsert()
Dim cShape As Shape
Dim cRange As Range
Dim cColumn As Long
On Error Resume Next
Application.ScreenUpdating = False
Set xRange = ActiveSheet.Range("j3:j4")
For Each cell In xRange
cName = cell
ActiveSheet.Shapes.AddPicture (cName), True, True, 100, 100, 70, 70
Set cShape = Selection.ShapeRange.Item(1)
If cShape Is Nothing Then GoTo line22
cColumn = cell.Column - 1
Set cRange = Cells(cell.Row, cColumn)
line22:
Set cShape = Nothing
Range("D5").Select
Next
Application.ScreenUpdating = True
End Sub
我终于找到了对我有用的东西 - 对于那些想要使用 URL 作为源
与文件一起存储图片的人 Option Explicit
Dim rng As Range
Dim cell As Range
Dim Filename As String
Sub URLPictureInsert()
Dim theShape As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
' Set to the range of cells you want to change to pictures
Set rng = ActiveSheet.Range("T1206:T1400")
For Each cell In rng
Filename = cell
' Use Shapes instead so that we can force it to save with the document
Set theShape = ActiveSheet.Shapes.AddPicture( _
Filename:=Filename, linktofile:=msoFalse, _
savewithdocument:=msoCTrue, _
Left:=cell.Left, Top:=cell.Top, Width:=15, Height:=15)
If theShape Is Nothing Then GoTo isnill
With theShape
.LockAspectRatio = msoTrue
' Shape position and sizes stuck to cell shape
.Top = cell.Top + 1
.Left = cell.Left + 1
.Height = cell.Height - 2
.Width = cell.Width - 2
' Move with the cell (and size, though that is likely buggy)
.Placement = xlMoveAndSize
End With
' Get rid of the
cell.ClearContents
isnill:
Set theShape = Nothing
Range("D2").Select
Next
Application.ScreenUpdating = True
Debug.Print "Done " & Now
End Sub