12
返回列表 上一主題 發帖

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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2011-9-28 16:55 | 顯示全部帖子
回復 1# oxrain
試試看
  1. Dim i As Integer
  2. Sub Ex()
  3.     Dim fs, f, e As Variant
  4.     Sheets(1).Activate
  5.     ActiveSheet.Pictures.Delete
  6.     i = 1
  7.     For Each e In Array("D:\PIC0", "D:\PIC01")
  8.         Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(e)
  9.         子資料夾 fs
  10.     Next
  11. End Sub
  12. Private Sub 子資料夾(TheFolder)
  13.     Dim fs As Object, f As Object
  14.     Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(TheFolder)
  15.     For Each f In fs.Files
  16.         If UCase(Mid(f, InStr(f, ".") + 1)) = "JPG" Then
  17.              With ActiveSheet.Pictures.Insert(f)
  18.                 .Top = Cells(i, "A").Top
  19.                 .Height = 49.5
  20.                 .ShapeRange.LockAspectRatio = msoTrue
  21.                 .ShapeRange.IncrementLeft 0.75
  22.             End With
  23.             i = i + 5
  24.        End If
  25.     Next
  26.     For Each f In fs.SubFolders
  27.          子資料夾 f
  28.     Next
  29. End Sub
複製代碼

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2012-11-2 16:11 | 顯示全部帖子
回復 3# whirlwind963
  1. Dim i As Integer, xCol As Integer
  2. Sub Ex()
  3.     Dim fs, f, e As Variant
  4.     Sheets(1).Activate
  5.     ActiveSheet.Pictures.Delete
  6.     'C2開始
  7.     i = 2       '列數
  8.     xCol = 3    '欄數
  9.     For Each e In Array("D:\相片")
  10.         Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(e)
  11.         子資料夾 fs
  12.     Next
  13. End Sub
  14. Private Sub 子資料夾(TheFolder)
  15.     Dim fs As Object, f As Object
  16.     Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(TheFolder)
  17.     For Each f In fs.Files
  18.         If UCase(Mid(f, InStr(f, ".") + 1)) = "JPG" Then
  19.              With ActiveSheet.Pictures.Insert(f)
  20.                 '.Top = Cells(i, "A").Top
  21.                  .Top = Cells(i, xCol).Top
  22.                  .Left = Cells(i, xCol).Left
  23.                 .Height = 49.5
  24.                 .Width = 49.5
  25.                 .ShapeRange.LockAspectRatio = msoTrue
  26.                 .ShapeRange.IncrementLeft 0.75
  27.             End With
  28.             i = i + 5
  29.               If i >= 5 * 10 Then  '10個圖就換一欄
  30.                 xCol = xCol + 1
  31.                 i = 2
  32.             End If
  33.        End If
  34.     Next
  35.     For Each f In fs.SubFolders
  36.          子資料夾 f
  37.     Next
  38. End Sub
複製代碼

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
3#
發表於 2012-11-3 15:06 | 顯示全部帖子
回復 7# whirlwind963
5# 問 :  C欄顯示圖片D欄顯示圖片的名稱  你已在6# 自行解答,

6# 問 : 取得檔案名稱(f.Name),不要完整的路徑 f

7# 問 : 檢查  NN= cells(2,1),MM=cells(3,1)  的路徑對嗎?
有辦法自己在儲存格輸入位址嗎? 不懂你的意思.

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 2012-11-19 17:22 | 顯示全部帖子
回復 9# 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:\相片")
  8.     For Each e In fs.subfolders  '資料夾集合物件
  9.         i = 2       '列數
  10.         Cells(i, xCol) = e.Name
  11.         For Each f In e.Files    '檔案集合物件
  12.             If UCase(Mid(f, InStr(f, ".") + 1)) = "JPG" Then
  13.                 i = i + 1
  14.                 With ActiveSheet.Pictures.Insert(f)
  15.                     .Top = Cells(i, xCol).Top
  16.                     .Left = Cells(i, xCol).Left
  17.                     .Height = 49.5
  18.                     .Width = 49.5
  19.                     Cells(i, xCol).RowHeight = .Height
  20.                     Cells(i, xCol).ColumnWidth = .Width / 5.5
  21.                     End With
  22.             End If
  23.         Next
  24.         xCol = xCol + 1   '欄數
  25.     Next
  26. End Sub
複製代碼

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
5#
發表於 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

GBKEE

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

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

TOP

GBKEE

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

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

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
8#
發表於 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

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
9#
發表於 2012-12-13 11:11 | 顯示全部帖子
本帖最後由 GBKEE 於 2012-12-13 11:15 編輯

回復 20# c_c_lai
程序中用 On Error Resume Next  有時會找不出錯誤點的
看一下  19#
  1.    
  2.            ' MyFile = Dir(e & "\*" & Cells(j, "C") & "*.*")  改用了   
  3.           If UCase(f) Like "*.JPG" Or UCase(f) Like "*.GIF" Or UCase(f) Like "*.BMP" Then
  4.                     '預防不是圖片檔
複製代碼

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
10#
發表於 2012-12-13 12:09 | 顯示全部帖子
回復 22# c_c_lai
2003版 沒有錯誤!!
錯誤點 前  Debug.Print f   看看: 是哪個圖檔,將他刪掉試試

TOP

        靜思自在 : 一個缺口的杯子，如果換一個角度看它，它仍然是圓的。
12
返回列表 上一主題