Pictures.Insert、Shapes.AddShape、Shapes.AddPicture差別 請高手指點

baconbacons

目前我的程式碼摘要如下(可以成功執行)：
              Set myPic = ActiveSheet.Pictures.Insert(myPath & "\" &  "1.jpg")
                With myPic
                    .ShapeRange.LockAspectRatio = msoFalse
                    .Top = picNumRng.Offset(0, 1).Top
                    .Left = picNumRng.Offset(0, 1).Left
                    .Width = picNumRng.Offset(0, 1).MergeArea.Width
                    .Height = picNumRng.Offset(0, 1).MergeArea.Height
                End With
問題如下：
1.後來發現Pictures.Insert 是利用連結方式讀取大量圖片，並非將圖片匯入到excel檔內，不符需求
2.經過google發現 http://blog.xuite.net/crdotlin/excel/9016086  的解法，知道有Shapes.AddShape的方式
    但活頁中有設計一個按鈕，如果要指定特定圖片時，也會將該按鈕算成一個Shape造成困擾
3.後來再發現 https://tw.knowledge.yahoo.com/question/question?qid=1612072502639 的解法
    知道Shapes.AddPicture 的方式，只是google及爬了家族的文章並沒有發現可以參考的文章
    自己試著將上述的程式碼中的Pictures.Insert以Shapes.AddPicture取代後執行，只是在上述程式碼第三行
    就會出現錯誤，不知道有無其他方法可以符合「匯入圖片」、「指定欄位插入」及「調整圖片大小」？
4.另外找到的這個方法也是不錯 http://blog.xuite.net/crdotlin/excel/9016086 只是無法理解怎麼做
    （可以將連結的圖片複製到剪貼簿後，再抓下來   提供參考）

GBKEE

回復 1# baconbacons

試試看

1. Option Explicit
   
2. Sub Ex_Shapes()
   
3.     Dim i As Integer, E As String, S As Shape, Rng As Range
   
4.     With ActiveSheet
   
5.         .Shapes.SelectAll '選定 Shape物件的集合
   
6.         Selection.Delete   '刪除 所有Shape物件
   
7.         For i = 0 To 9
   
8.             E = "http://forum.twbts.com/uc_server/avatar.php?uid=16665&size=middle"
   
9.             If i Mod 2 <> 0 Then E = "http://forum.twbts.com/uc_server/avatar.php?uid=16&size=middle"
   
10.             With .Range("A1").Offset(i * 6)
    
11.                 With ActiveSheet.Shapes.AddShape(i + 1, .Left, .Top, .Cells.Resize(, 5).Width, .Cells.Resize(5).Height)
    
12.                     .Fill.UserPicture E
    
13.                 End With
    
14.                 With .Offset(, 10)
    
15.                     ActiveSheet.Shapes.AddPicture E, True, True, .Left, .Top, .Cells.Resize(, 5).Width, .Cells.Resize(5).Height
    
16.                 End With
    
17.             End With
    
18.         Next
    
19.         
    
20.         '新增按鈕
    
21.         Set Rng = .Range("A1").Offset(, 7)
    
22.         .OLEObjects.Add ClassType:="Forms.CommandButton.1", Link:=False, DisplayAsIcon:=True, Left:=Rng.Left, Top:=Rng.Top, Width:=Rng.Resize(, 2).Width, Height:=Rng.Resize(2).Height
    
23.         
    
24.         ' 活頁中有設計一個按鈕，如果要指定特定圖片時，也會將該按鈕算成一個Shape造成困擾
    
25.         '查看按鈕 .Type, .Name, .AutoShapeType
    
26.         For Each S In ActiveSheet.Shapes
    
27.             Debug.Print S.Type, S.Name, S.AutoShapeType
    
28.             If S.Type = 12 Then MsgBox S.Name
    
29.         Next
    
30.     End With
    
31. End Sub

複製代碼

baconbacons

回復 2# GBKEE
感謝GBKEE大的指導，確實是可行的，另外延伸請教一個關於匯入圖片的問題：
假設我先執行程式並「依序」匯入了100張圖片(假設由B1~B100排列)，且後續在第57格欄位「新增插入」另張圖片，原始圖片均順延排序至101格
經實際執行，原始的圖片電腦會認定這100張的圖片依序是Shape(1)~Shape(100)，雖然後續插入第57張圖片(由上往下算)，但會被認定為Shape(101)
因此接著我想「刪除」第60張圖片（指由上往下算，但電腦認定該圖為Shape(59)），實際上刪除的其實是Shape(60)，而不是我想要刪除的Shape(59)
簡言之
我怎麼克服圖片所見的實際順序與圖片匯入順序的差別，以利我後續在操作指定圖片時的困擾？

GBKEE

回復 3# baconbacons

1. Option Explicit
   
2. Const xP_First = "B3"   '指定第ㄧ張圖片的位置
   
3. Const xP_Width = 5      '圖片的寬度:圖片的位置儲存格擴充的欄數
   
4. Const xP_Height = 5     '圖片的高度:圖片的位置儲存格擴充的列數
   
5. Const xP_間隔列 = 6     '圖片間的間隔列數
   
6. Dim d As Object
   
7. Sub Ex_圖片插入()
   
8.     Dim E As String, Rng As Range, Position As Integer, R As Integer
   
9.     xP_Seat
   
10.     With ActiveSheet
    
11.         If d.Count > 0 Then
    
12.             On Error Resume Next
    
13.             Position = InputBox("本頁計有 " & d.Count & " 照片", "指定位置", d.Count + 1)
    
14.             On Error GoTo 0
    
15.             If Position = 0 Then Exit Sub
    
16.              If Position <= d.Count Then
    
17.                 Position = Position - 1
    
18.             Else
    
19.                 Position = d.Count
    
20.             End If
    
21.         Else
    
22.             If MsgBox("新增圖片 !!", vbDefaultButton1 + vbYesNo) = vbYes Then
    
23.                 Position = 0
    
24.             Else
    
25.                 Exit Sub
    
26.             End If
    
27.         End If
    
28.         If d.Count > 0 Then
    
29.             For R = d.Count To Position + 1 Step -1   '由下往上移動圖片到下面
    
30.                 d(R).Top = d(R).TopLeftCell.Offset(xP_間隔列).Top
    
31.                 Set d(R + 1) = d(R)
    
32.         Next
    
33.         End If
    
34.         R = .Range(xP_First).Row
    
35.         With .Range(xP_First).Offset(Position * xP_間隔列)
    
36.             If Position Mod 2 = 0 Then
    
37.                 E = "http://forum.twbts.com/templates/discuz6/images/logotop.gif"
    
38.             Else
    
39.                 E = "http://forum.twbts.com/uc_server/avatar.php?uid=16665&size=middle"
    
40.             End If
    
41.             With ActiveSheet.Shapes.AddPicture(E, True, True, .Left, .Top, .Resize(, xP_Width).Width, .Resize(xP_Height).Height)
    
42.                     .Fill.UserPicture E
    
43.                     Set d(Int((.TopLeftCell.Row - R) / xP_間隔列) + 1) = .OLEFormat.Object
    
44.                 End With
    
45.             End With
    
46.     End With
    
47. End Sub
    
48. Sub Ex_圖片刪除()
    
49.     Dim E As String, Rng As Range, Position As Integer, R As Integer
    
50.     xP_Seat
    
51.     With ActiveSheet
    
52.         If d.Count = 0 Then
    
53.             MsgBox "沒有圖片可刪除 !!"
    
54.             Exit Sub
    
55.         End If
    
56.         On Error Resume Next
    
57.         Position = InputBox("本頁計有 " & d.Count & " 照片" & vbLf & "數字如 > " & d.Count & " 為刪除所有圖片", "刪除位置", d.Count)
    
58.         On Error GoTo 0
    
59.         If Position = 0 Then Exit Sub
    
60.         If Position > d.Count Then
    
61.             If MsgBox("刪除所有圖片 !!", vbDefaultButton1 + vbYesNo) = vbYes Then xP_All_Delete
    
62.             Exit Sub
    
63.         End If
    
64.         d(Position).Delete
    
65.         For R = Position + 1 To d.Count '由上往下移動圖片到上面
    
66.                 d(R).Top = d(R).TopLeftCell.Offset(-xP_間隔列).Top
    
67.                 Set d(R - 1) = d(R)
    
68.         Next
    
69.         d.Remove (d.Count)
    
70.         
    
71.     End With
    
72. End Sub
    
73. Private Sub xP_Seat() '字點物件: 導入圖片欄在指定欄的照片
    
74.     Dim S As Shape, Rng As Range, R As Integer
    
75.     Set d = CreateObject("scripting.dictionary")
    
76.     With ActiveSheet
    
77.        With .Range(xP_First)
    
78.             Set Rng = .EntireColumn
    
79.             R = .Row
    
80.         End With
    
81.         For Each S In .Shapes
    
82.             If Not Intersect(Rng, S.TopLeftCell) Is Nothing Then '圖片TopLeftCell是在xP_First所在的欄
    
83.                 Set d(Int((S.TopLeftCell.Row - R) / xP_間隔列) + 1) = S.OLEFormat.Object
    
84.             End If
    
85.         Next
    
86.     End With
    
87. End Sub
    
88. Private Sub xP_All_Delete() '刪除位置在(xP_First = "B1")欄所有圖片
    
89.     Dim S As Shape, Rng As Range
    
90.     Set d = CreateObject("scripting.dictionary")
    
91.     With ActiveSheet
    
92.         Set Rng = .Range(xP_First).EntireColumn
    
93.         For Each S In .Shapes
    
94.             If Not Intersect(Rng, S.TopLeftCell) Is Nothing Then S.Delete
    
95.         Next
    
96.     End With
    
97. End Sub

複製代碼