所以我有以下代碼可以正常作業，并使用帶有 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
uj5u.com熱心網友回復：
我終于找到了對我有用的東西 - 對于那些希望使用源 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
轉載請註明出處，本文鏈接：https://www.uj5u.com/qita/471955.html
上一篇：如果url是shop，則添加部分
下一篇：Maxifs的陣列公式