返回列表 上一主題 發帖

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

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2014-6-10 14:58 | 顯示全部帖子
回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2014-6-13 21:15 | 顯示全部帖子
回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 每天無所事事，是人生的消費者，積極、有用才是人生的創造者。
返回列表 上一主題