麻辣家族討論版版 - Powered by Discuz! Board

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

複製代碼

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

複製代碼