whirlwind963

回復 10# GBKEE
請問一下
我的資料夾名稱是日期格式(2012/12/10)
子資料夾的名稱是小時格式(00-23)24個資料夾
如果我在A1輸入06  B1輸入12
就可以看到06-12這之間所有的圖片
這樣程式要怎麼改呢

GBKEE

回復 11# whirlwind963

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim fs, f, e As Variant, i As Integer, xCol As Integer
   
4.     Sheets(1).Activate
   
5.     ActiveSheet.Pictures.Delete
   
6.     xCol = 3    '欄數
   
7.     Set fs = CreateObject("Scripting.FileSystemObject").GetFolder("D:\2012-12-12")
   
8.     '**檔案,資料夾的命名中: 不可有  / \ : * ? < > |  這些字元
   
9.     For Each e In fs.subfolders  '資料夾集合物件
   
10.         i = 2       '列數
    
11.         If e.Name >= [A1] And e.Name <= Range("B1") Then '如果我在A1輸入06  B1輸入12
    
12.         'If e.Name >= 5 And e.Name <= 10 Then            '5 到 10
    
13.             For Each f In e.Files    '檔案集合物件
    
14.                 i = i + 1
    
15.                 With ActiveSheet.Pictures.Insert(f)
    
16.                     .Top = Cells(i, xCol).Top
    
17.                     .Left = Cells(i, xCol).Left
    
18.                     .Height = 49.5
    
19.                     .Width = 49.5
    
20.                     Cells(i, xCol).RowHeight = .Height
    
21.                     Cells(i, xCol).ColumnWidth = .Width / 5.5
    
22.                 End With
    
23.             Next
    
24.             xCol = xCol + 1   '欄數
    
25.         End If
    
26.     Next
    
27. End Sub

複製代碼

whirlwind963

回復 12# GBKEE

我加了 If e.Name >= [A1] And e.Name <= Range("B1") Then 這一行後
無法顯示圖片耶
請問有別的方法嗎
還是哪裡錯了呢

GBKEE

回復 13# whirlwind963
這裡有改嗎?

1. Set fs = CreateObject("Scripting.FileSystemObject").GetFolder("D:\2012-12-12")
   
2.                       '**檔案,資料夾的命名中: 不可有  / \ : * ? < > |  這些字元

複製代碼

whirlwind963

回復 14# GBKEE
有阿
我確認檔名跟資料夾都沒有那些字元

whirlwind963

回復 16# GBKEE
我只改了路徑而已
其他的程式碼都一樣
在A1跟B1輸入數字
還是無法顯示圖片

GBKEE

回復 16# whirlwind963
上傳:檔案,資料夾 看看

whirlwind963

回復 17# GBKEE
因為上傳檔案的限制
我刪掉一些檔案
麻煩幫我測試看看

GBKEE

回復 18# whirlwind963

1. Option Explicit
   
2.     Sub Ex()
   
3.         Dim fs, f, e As Variant, i As Integer, xCol As Integer
   
4.         Sheets(1).Activate
   
5.         ActiveSheet.Pictures.Delete
   
6.         xCol = 3    '欄數
   
7.         Set fs = CreateObject("Scripting.FileSystemObject").GetFolder("D:\2012-12-12")
   
8.         '**檔案,資料夾的命名中: 不可有  / \ : * ? < > |  這些字元
   
9.         For Each e In fs.subfolders  '資料夾集合物件
   
10.             i = 2       '列數
    
11.             If Val(e.Name) >= [A1] And Val(e.Name) <= Range("B1") Then '如果我在A1輸入06  B1輸入12
    
12.             'If e.Name >= 5 And e.Name <= 15 Then            '5 到 10
    
13.                 For Each f In e.Files    '檔案集合物件
    
14.                     If UCase(f) Like "*.JPG" Or UCase(f) Like "*.GIF" Or UCase(f) Like "*.BMP" Then
    
15.                     '預防不是圖片檔
    
16.                     i = i + 1
    
17.                     With ActiveSheet.Pictures.Insert(f)
    
18.                         .Top = Cells(i, xCol).Top
    
19.                         .Left = Cells(i, xCol).Left
    
20.                         .Height = 49.5
    
21.                         .Width = 49.5
    
22.                         Cells(i, xCol).RowHeight = .Height
    
23.                         Cells(i, xCol).ColumnWidth = .Width / 5.5
    
24.                     End With
    
25.                     End If
    
26.                 Next
    
27.                 xCol = xCol + 1   '欄數
    
28.             End If
    
29.         Next
    
30.     End Sub

複製代碼

c_c_lai

回復 19# GBKEE
GBKEE 版大， 早安!
我實際測了一陣子，發現 一執行到 With ActiveSheet.Pictures.Insert(f)
這一行便出現 104 的錯誤訊息， 經檢查語法也沒錯，就是會有錯誤訊息。
也令我百思不解。 我另外將其中 GetFolder 的處裡模組放入到另一支程式
裏測試都非常正常，我將程式碼  (在ThisWorkbook執行) 附上讓您參考。

1. Option Explicit
   
2. 
   
3. Sub Ex()
   
4.     Dim fs As Object, f As Variant, e As Variant
   
5.     Dim j As Integer, MyPath As String, MyFile As String
   
6.    
   
7.     j = 2
   
8.     MyPath = ActiveWorkbook.Path & "\My Pictures\"
   
9.    
   
10.     Application.ScreenUpdating = False
    
11.    
    
12.     Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(MyPath)
    
13.     For Each e In fs.subfolders  ' 資料夾集合物件 e = "D:\Workspaces\DATA\Excel 範例集錦\TXT\2012-12-12\14"
    
14.         '  For Each f In e.Files  ' 檔案集合物件 f = "D:\Workspaces\DATA\Excel 範例集錦\TXT\2012-12-12\14\Winter.jpg"
    
15.         With Sheets("工作表1")
    
16.             .Pictures.Delete
    
17.             While Cells(j, "C") <> ""
    
18.                 If UCase(.Cells(j, "C")) Like "*ABCD*" Then  '字串中有"ABCD"
    
19.                     'UCase 函數 傳回一個 Variant (String)，所含為轉成大寫之字串。
    
20.                     .Cells(j, "D").Select
    
21.                                        
    
22.                      Selection.RowHeight = 100
    
23.                      Selection.ColumnWidth = 25
    
24.                                             
    
25.                      On Error Resume Next
    
26.                      '   MyFile = Dir(e & "\*" & Cells(j, "C") & "*.*", vbDirectory)
    
27.                      MyFile = Dir(e & "\*" & Cells(j, "C") & "*.*")
    
28.                      If MyFile <> "" Then
    
29.                          '  With .Pictures.Insert(MyPath & MyFile)
    
30.                          With .Pictures.Insert(e & "\" & MyFile)
    
31.                              .Top = Cells(j, "D").Top
    
32.                              .Left = Cells(j, "D").Left
    
33.                              .Height = 90
    
34.                              .Width = 120
    
35.                              .Cells(j, "D").RowHeight = .Height
    
36.                              .Cells(j, "D").ColumnWidth = .Width / 5.5
    
37.                              '  .ShapeRange.LockAspectRatio = msoTrue
    
38.                              '  在調整圖案大小時，可以分別地調整圖案的長度和寬度
    
39.                              '  .ShapeRange.LockAspectRatio = msoFalse
    
40.                              '  .ShapeRange.Height = IIf(.ShapeRange.Height > 98, 98, .ShapeRange.Height)
    
41.                              '  .ShapeRange.Width = IIf(.ShapeRange.Width > 150, 150, .ShapeRange.Width)
    
42.                              '  .ShapeRange.Rotation = 0#
    
43.                              '  .ShapeRange.IncrementLeft 2#
    
44.                              '  .ShapeRange.IncrementTop 1#
    
45.                              '  .Placement = xlMoveAndSize
    
46.                              '  .PrintObject = True
    
47.                          End With
    
48.                          .Cells(j, "E") = MyFile
    
49.                      End If
    
50.                 End If
    
51.                 j = j + 1
    
52.             Wend
    
53.             .Range("C2").Select
    
54.         End With
    
55.         '  Next    '  For Each f In e.Files
    
56.     Next           '  For Each e In fs.subfolders
    
57.     Application.ScreenUpdating = True
    
58. End Sub

複製代碼