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

Sub 圖片重新排列()
Dim xSP As Shape
Dim Ksz As Double, Kss As Double, Sp As Double, Cz As Double, G As Double, K As Double
Dim Mh As Integer, II As Integer
Ksz = ActiveCell.Left '開始左
Kss = ActiveCell.Top '開始上
Sp = 35 '水平
Cz = 160 '垂直
G = 0.1 '高
K = 170 '寬
Mh = 4 '每行
II = 0
For Each xSP In ActiveSheet.Shapes
If xSP.Type = msoPicture Then
With xSP
.LockAspectRatio = msoFalse
.Left = Ksz + (Sp + K) * (II Mod Mh)
.Top = Kss + (Cz + G) * (II \ Mh)
.Width = 190
.Height = 143
II = II + 1
End With
End If
Next
End Sub

複製代碼

Option Explicit
Sub Ex()
Dim xPath As String, xFile As String, Sp As Integer, Cz As Integer, G As Long, K As Integer, Mh As Integer
Dim ii As Integer
xPath = "D:\相片\89年\" '圖片的資料夾
'Dir 函數傳回一個 String ，用以表示合乎條件、檔案屬性、磁碟標記的一個檔案名稱、或目錄、檔案夾名稱。
xFile = Dir(xPath & "*.jpg") '圖片的副檔名為jpg
'xFile = Dir(xPath & "*.*") '圖片的資料夾都是圖片檔
With ActiveSheet '作用中的工作表
Sp = 35 '水平
Cz = 160 '垂直
G = 0.1 '高
K = 170 '寬
Mh = 4 '每行
.Pictures.Delete '刪除所有圖片
.[a:a] = "" '清除 A欄資料
ii = 1 '設定為1
Application.ScreenUpdating = False
Do
.Cells(ii, 1).Select '選擇A欄的第 ii 儲存格(ActiveCell :作用中的儲存格)
.Cells(ii, 1) = xFile '寫上檔名
With .Pictures.Insert(xPath & xFile) '插入圖片
.Left = ActiveCell.Offset(, 2).Left '插入圖片的左端位置是: ActiveCell 右移2欄的左端
.Top = ActiveCell.Offset(, 2).Top '插入圖片的上端位置是: ActiveCell 右移2欄的上端
.Width = 190 '設定插入圖片的寬度
.Height = 143 '設定插入圖片的高度
ActiveCell.Offset(, 2).ColumnWidth =33 '設定插入圖片所在儲存格的寬
ActiveCell.Offset(, 2).RowHeight = .Height '設定插入圖片所在儲存格的高
End With
xFile = Dir '繼續尋找下一個檔案
ii = ii + 1 'A欄的第 ii 儲存格往下一列
Loop Until xFile = "" '離開 Do 迴圈的條件是: 找不到檔案
.[A1].Select
Selection.EntireColumn.AutoFit 'AutoFit 方法將範圍中的欄寬和列高調整為最適當的值
Application.ScreenUpdating = True 'ScreenUpdating 屬性定如果螢幕更新功能是開啟的則為 True。讀/寫 Boolean
End With
End Sub

複製代碼