123
返回列表 上一主題 發帖

[發問] 如何 插入 資料夾中含子資料夾的 圖片

whirlwind963

帖子
29 
主題
7 
精華
0 
積分
42 
點名
0  
作業系統
XP 
軟體版本
OFFICE 2003 
閱讀權限
10 
註冊時間
2012-9-22 
最後登錄
2013-1-9 
11# 跳轉到 »
發表於 2012-12-11 22:29 | 只看該作者
回復 10# GBKEE
請問一下
我的資料夾名稱是日期格式(2012/12/10)
子資料夾的名稱是小時格式(00-23)24個資料夾
如果我在A1輸入06  B1輸入12
就可以看到06-12這之間所有的圖片
這樣程式要怎麼改呢

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
12#
發表於 2012-12-12 08:35 | 只看該作者
回復 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
複製代碼

TOP

whirlwind963

帖子
29 
主題
7 
精華
0 
積分
42 
點名
0  
作業系統
XP 
軟體版本
OFFICE 2003 
閱讀權限
10 
註冊時間
2012-9-22 
最後登錄
2013-1-9 
13#
發表於 2012-12-12 11:01 | 只看該作者
回復 12# GBKEE

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

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
14#
發表於 2012-12-12 11:55 | 只看該作者
回復 13# whirlwind963
這裡有改嗎?
  1. Set fs = CreateObject("Scripting.FileSystemObject").GetFolder("D:\2012-12-12")
  2.                       '**檔案,資料夾的命名中: 不可有  / \ : * ? < > |  這些字元
複製代碼

TOP

whirlwind963

帖子
29 
主題
7 
精華
0 
積分
42 
點名
0  
作業系統
XP 
軟體版本
OFFICE 2003 
閱讀權限
10 
註冊時間
2012-9-22 
最後登錄
2013-1-9 
15#
發表於 2012-12-12 13:50 | 只看該作者
回復 14# GBKEE
有阿
我確認檔名跟資料夾都沒有那些字元

TOP

whirlwind963

帖子
29 
主題
7 
精華
0 
積分
42 
點名
0  
作業系統
XP 
軟體版本
OFFICE 2003 
閱讀權限
10 
註冊時間
2012-9-22 
最後登錄
2013-1-9 
16#
發表於 2012-12-12 16:38 | 只看該作者
回復 16# GBKEE
我只改了路徑而已
其他的程式碼都一樣
在A1跟B1輸入數字
還是無法顯示圖片

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
17#
發表於 2012-12-12 20:21 | 只看該作者
回復 16# whirlwind963
上傳:檔案,資料夾 看看

TOP

whirlwind963

帖子
29 
主題
7 
精華
0 
積分
42 
點名
0  
作業系統
XP 
軟體版本
OFFICE 2003 
閱讀權限
10 
註冊時間
2012-9-22 
最後登錄
2013-1-9 
18#
發表於 2012-12-12 21:38 | 只看該作者
回復 17# GBKEE
因為上傳檔案的限制
我刪掉一些檔案
麻煩幫我測試看看

TEST.rar (889.57 KB)

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
19#
發表於 2012-12-13 06:14 | 只看該作者
回復 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
複製代碼

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
20#
發表於 2012-12-13 11:00 | 只看該作者
回復 19# GBKEE
GBKEE 版大， 早安!
我實際測了一陣子，發現 一執行到 With ActiveSheet.Pictures.Insert(f)
這一行便出現 104 的錯誤訊息， 經檢查語法也沒錯，就是會有錯誤訊息。
也令我百思不解。 我另外將其中 GetFolder 的處裡模組放入到另一支程式
裏測試都非常正常，我將程式碼  (在ThisWorkbook執行) 附上讓您參考。
  1. Option Explicit

  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
複製代碼

TOP

        靜思自在 : 多做多得。少做多失。
123
返回列表 上一主題