Pictures.Insert、Shapes.AddShape、Shapes.AddPicture差別 請高手指點
- 帖子
- 36
- 主題
- 6
- 精華
- 0
- 積分
- 50
- 點名
- 0
- 作業系統
- windows xp
- 軟體版本
- office 2010
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2014-2-20
- 最後登錄
- 2015-3-6
|
Pictures.Insert、Shapes.AddShape、Shapes.AddPicture差別 請高手指點
目前我的程式碼摘要如下(可以成功執行)：
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 只是無法理解怎麼做
（可以將連結的圖片複製到剪貼簿後，再抓下來 提供參考） |
|
|
HELLO !!
|
|
|
|
|
- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
2#
發表於 2014-6-10 14:58
| 只看該作者
回復 1# baconbacons
試試看- Option Explicit
- Sub Ex_Shapes()
- Dim i As Integer, E As String, S As Shape, Rng As Range
- With ActiveSheet
- .Shapes.SelectAll '選定 Shape物件的集合
- Selection.Delete '刪除 所有Shape物件
- For i = 0 To 9
- E = "http://forum.twbts.com/uc_server/avatar.php?uid=16665&size=middle"
- If i Mod 2 <> 0 Then E = "http://forum.twbts.com/uc_server/avatar.php?uid=16&size=middle"
- With .Range("A1").Offset(i * 6)
- With ActiveSheet.Shapes.AddShape(i + 1, .Left, .Top, .Cells.Resize(, 5).Width, .Cells.Resize(5).Height)
- .Fill.UserPicture E
- End With
- With .Offset(, 10)
- ActiveSheet.Shapes.AddPicture E, True, True, .Left, .Top, .Cells.Resize(, 5).Width, .Cells.Resize(5).Height
- End With
- End With
- Next
-
- '新增按鈕
- Set Rng = .Range("A1").Offset(, 7)
- .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
-
- ' 活頁中有設計一個按鈕，如果要指定特定圖片時，也會將該按鈕算成一個Shape造成困擾
- '查看按鈕 .Type, .Name, .AutoShapeType
- For Each S In ActiveSheet.Shapes
- Debug.Print S.Type, S.Name, S.AutoShapeType
- If S.Type = 12 Then MsgBox S.Name
- Next
- End With
- End Sub
|
|
|
|
|
|
|
|
- 帖子
- 36
- 主題
- 6
- 精華
- 0
- 積分
- 50
- 點名
- 0
- 作業系統
- windows xp
- 軟體版本
- office 2010
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2014-2-20
- 最後登錄
- 2015-3-6
|
3#
發表於 2014-6-12 19:22
| 只看該作者
回復 2# GBKEE
感謝GBKEE大的指導，確實是可行的，另外延伸請教一個關於匯入圖片的問題：
假設我先執行程式並「依序」匯入了100張圖片(假設由B1~B100排列)，且後續在第57格欄位「新增插入」另張圖片，原始圖片均順延排序至101格
經實際執行，原始的圖片電腦會認定這100張的圖片依序是Shape(1)~Shape(100)，雖然後續插入第57張圖片(由上往下算)，但會被認定為Shape(101)
因此接著我想「刪除」第60張圖片（指由上往下算，但電腦認定該圖為Shape(59)），實際上刪除的其實是Shape(60)，而不是我想要刪除的Shape(59)
簡言之
我怎麼克服圖片所見的實際順序與圖片匯入順序的差別，以利我後續在操作指定圖片時的困擾？ |
|
|
HELLO !!
|
|
|
|
|
- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
|
4#
發表於 2014-6-13 21:15
| 只看該作者
回復 3# baconbacons - Option Explicit
- Const xP_First = "B3" '指定第ㄧ張圖片的位置
- Const xP_Width = 5 '圖片的寬度:圖片的位置儲存格擴充的欄數
- Const xP_Height = 5 '圖片的高度:圖片的位置儲存格擴充的列數
- Const xP_間隔列 = 6 '圖片間的間隔列數
- Dim d As Object
- Sub Ex_圖片插入()
- Dim E As String, Rng As Range, Position As Integer, R As Integer
- xP_Seat
- With ActiveSheet
- If d.Count > 0 Then
- On Error Resume Next
- Position = InputBox("本頁計有 " & d.Count & " 照片", "指定位置", d.Count + 1)
- On Error GoTo 0
- If Position = 0 Then Exit Sub
- If Position <= d.Count Then
- Position = Position - 1
- Else
- Position = d.Count
- End If
- Else
- If MsgBox("新增圖片 !!", vbDefaultButton1 + vbYesNo) = vbYes Then
- Position = 0
- Else
- Exit Sub
- End If
- End If
- If d.Count > 0 Then
- For R = d.Count To Position + 1 Step -1 '由下往上移動圖片到下面
- d(R).Top = d(R).TopLeftCell.Offset(xP_間隔列).Top
- Set d(R + 1) = d(R)
- Next
- End If
- R = .Range(xP_First).Row
- With .Range(xP_First).Offset(Position * xP_間隔列)
- If Position Mod 2 = 0 Then
- E = "http://forum.twbts.com/templates/discuz6/images/logotop.gif"
- Else
- E = "http://forum.twbts.com/uc_server/avatar.php?uid=16665&size=middle"
- End If
- With ActiveSheet.Shapes.AddPicture(E, True, True, .Left, .Top, .Resize(, xP_Width).Width, .Resize(xP_Height).Height)
- .Fill.UserPicture E
- Set d(Int((.TopLeftCell.Row - R) / xP_間隔列) + 1) = .OLEFormat.Object
- End With
- End With
- End With
- End Sub
- Sub Ex_圖片刪除()
- Dim E As String, Rng As Range, Position As Integer, R As Integer
- xP_Seat
- With ActiveSheet
- If d.Count = 0 Then
- MsgBox "沒有圖片可刪除 !!"
- Exit Sub
- End If
- On Error Resume Next
- Position = InputBox("本頁計有 " & d.Count & " 照片" & vbLf & "數字如 > " & d.Count & " 為刪除所有圖片", "刪除位置", d.Count)
- On Error GoTo 0
- If Position = 0 Then Exit Sub
- If Position > d.Count Then
- If MsgBox("刪除所有圖片 !!", vbDefaultButton1 + vbYesNo) = vbYes Then xP_All_Delete
- Exit Sub
- End If
- d(Position).Delete
- For R = Position + 1 To d.Count '由上往下移動圖片到上面
- d(R).Top = d(R).TopLeftCell.Offset(-xP_間隔列).Top
- Set d(R - 1) = d(R)
- Next
- d.Remove (d.Count)
-
- End With
- End Sub
- Private Sub xP_Seat() '字點物件: 導入圖片欄在指定欄的照片
- Dim S As Shape, Rng As Range, R As Integer
- Set d = CreateObject("scripting.dictionary")
- With ActiveSheet
- With .Range(xP_First)
- Set Rng = .EntireColumn
- R = .Row
- End With
- For Each S In .Shapes
- If Not Intersect(Rng, S.TopLeftCell) Is Nothing Then '圖片TopLeftCell是在xP_First所在的欄
- Set d(Int((S.TopLeftCell.Row - R) / xP_間隔列) + 1) = S.OLEFormat.Object
- End If
- Next
- End With
- End Sub
- Private Sub xP_All_Delete() '刪除位置在(xP_First = "B1")欄所有圖片
- Dim S As Shape, Rng As Range
- Set d = CreateObject("scripting.dictionary")
- With ActiveSheet
- Set Rng = .Range(xP_First).EntireColumn
- For Each S In .Shapes
- If Not Intersect(Rng, S.TopLeftCell) Is Nothing Then S.Delete
- Next
- End With
- End Sub
|
|
|
|
|
|
|
|
