[發問] EXCEL ,如何把圖片的檔案名都顯示出來???

spiritwing

我現在是用以下的VBA,本人不會VBA的,都是網上找回來的 ,
圖片是加好了,但是因為老闆要每個圖下邊都要註名圖片的檔案名,我的圖有幾千個....一個一個加...我想今天都不用下斑了
所以希望各位老師可以教一下我要如何做

1. Sub 圖片重新排列()
   
2. Dim xSP As Shape
   
3. Dim Ksz As Double, Kss As Double, Sp As Double, Cz As Double, G As Double, K As Double
   
4. Dim Mh As Integer, II As Integer
   
5. Ksz = ActiveCell.Left '開始左
   
6. Kss = ActiveCell.Top '開始上
   
7. Sp = 35   '水平
   
8. Cz = 160  '垂直
   
9. G = 0.1    '高
   
10. K = 170     '寬
    
11. Mh = 4     '每行
    
12. II = 0
    
13. For Each xSP In ActiveSheet.Shapes
    
14.      If xSP.Type = msoPicture Then
    
15.          With xSP
    
16.              .LockAspectRatio = msoFalse
    
17.              .Left = Ksz + (Sp + K) * (II Mod Mh)
    
18.              .Top = Kss + (Cz + G) * (II \ Mh)
    
19.              .Width = 190
    
20.              .Height = 143
    
21.              II = II + 1
    
22.          End With
    
23.      End If
    
24. Next
    
25. End Sub

複製代碼

GBKEE

回復 1# spiritwing

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

複製代碼

fusayloveme

回復 2# GBKEE

GBKEE大您好，對於此帖內容非常有興趣，想請問一下，依照您提供的代碼輸入後，
發生了如圖片中一樣的錯誤，請問該如何解決呢? 感激不盡 ^^
   

下載 (230.21 KB)
問題

2012-3-1 09:30

Hsieh

回復 3# fusayloveme

2007不支援Pictures.Insert

fusayloveme

回復 4# Hsieh

謝謝~Hsieh大 ^_^