- 註冊時間
- 2006-8-14
- 最後登錄
- 2022-11-1
- 主題
- 查看
- 積分
- 19880
- 閱讀權限
- 140
- 文章
- 375
- 相冊
- 1
- 日誌
- 0
狀態︰
離線
|
01快速批次刪除所有的圖檔
02.快速批次將圖檔匯入到指定的儲存格
03.除了圖還有超連結
程式碼:
Sub 縮圖()
'1.資料夾與副檔名的指定
sPath = "C:\Users\Administrator\Desktop\APP\"
sFile = Dir(sPath & "*.png")
'2.設定寬與高
Range("A1").Select
Cells.RowHeight = 100
Columns("A").ColumnWidth = 18
'3.迴圈插入所有縮圖
Do While sFile <> ""
'插入圖片檔
ActiveSheet.Shapes.AddPicture sPath & sFile, True, True, 0, iTop, 90, 90
iTop = iTop + 100
'搜尋下一個檔案
sFile = Dir()
ActiveCell.Offset(1).Select
Loop
Range("A1").Select
End Sub
Sub 縮圖與超連結()
'1.資料夾與副檔名的指定
sPath = "C:\Users\Administrator\Desktop\APP\"
sFile = Dir(sPath & "*.png")
'2.設定寬與高
Range("A1").Select
Cells.RowHeight = 100
Columns("A:B").ColumnWidth = 18
'3.迴圈插入所有縮圖
Do While sFile <> ""
'插入圖片檔
ActiveSheet.Shapes.AddPicture sPath & sFile, True, True, 110, iTop, 90, 90
iTop = iTop + 100
'插入超連結
ActiveCell.WrapText = True
ActiveCell.Hyperlinks.Add Selection, sPath & sFile
'輸入sPath
'ActiveCell.Offset(, -1).Value = sPath
'搜尋下一個檔案
sFile = Dir()
ActiveCell.Offset(1).Select
Loop
Range("A1").Select
End Sub
Sub 刪除所有圖文()
Cells.ClearContents
For Each Sh In ActiveSheet.Shapes
Sh.Delete
Next
End Sub
|
|