123
返回列表 上一主題 發帖

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

oxrain

帖子
1 
主題
1 
精華
0 
積分
2 
點名
0  
作業系統
XP 
軟體版本
office2003 
閱讀權限
10 
註冊時間
2011-9-28 
最後登錄
2012-2-24 
1# 跳轉到 » 正序看帖
打印
tT
發表於 2011-9-28 15:01 | 只看該作者

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

本帖最後由 oxrain 於 2011-9-28 15:06 編輯

請問 各位大大  要如何插入 資料夾中 含子資料夾  的圖片呢
因為將東西以資料夾 做分類存放

根目錄在D碟，主資料夾在 D:\PIC 及 D:\PIC01
而 D:\PIC 中有 001~070 不等約莫 50來個資料夾
而 D:\PIC01 中也有 010~070 約40來個

加上 D:\PIC 及 D:\PIC01 下，也有不在子資料夾的jpg檔
請教各位前輩  要如何加入呢？想說一個一個列，但會弄個好幾天，而且好笨...>.<
附上我的程式檔，麻煩各位賜教，我的頭快要爆了
  1. Sub 插入圖片()
  2.         Dim modelno, modelno1, picins As String
  3.         Dim modelno2%
  4.         modelno = InputBox("A1請輸入A1、C6請輸入C6，以此類推", "輸入商品型號起始欄位", "")
  5.         picins = InputBox("插入A欄請輸入A、插入C欄請輸入C，以此類推", "輸入商品圖片插入欄位", "")
  6.         If modelno = "" Or picins = "" Then
  7.           MsgBox("末確實輸入")
  8.         Else
  9.             modelno1 = Left(modelno, 1)
  10.           modelno2 = Mid(modelno, 2, 3)
  11.           Columns("" & picins & ":" & picins & "").Select
  12.           Selection.ColumnWidth = 20
  13.           Rows("" & modelno2 & ":9999").Select
  14.           Selection.RowHeight = 50
  15.           Dim a%
  16.           Dim name As String
  17.             For a = modelno2 To 9999
  18.                 name = Range("" & modelno1 & "" & a & "")
  19.                   If name <> "" Then
  20.                         Range("" & picins & "" & a & "").Select
  21.                           If Dir("D:\PICTURE\001\" & name & ".jpg") <> "" Then
  22.                                 ActiveSheet.Pictures.Insert(P).Select
  23.                                   Selection.ShapeRange.LockAspectRatio = msoTrue
  24.                                   Selection.ShapeRange.Height = 49.5
  25.                                   Selection.ShapeRange.IncrementLeft 0.75
  26.                           Else
  27.                                   Range("" & picins & "" & a & "") = "無圖片"
  28.                           End If
  29.                 End If
  30.             Next
  31.         End If
  32. End Sub
複製代碼
收藏 分享

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
30#
發表於 2012-12-15 11:35 | 只看該作者
回復 29# whirlwind963
是一樣的: 這引數 TheFolder 沒宣告型態 就是  As Variant
  1. Variant 資料型態
  2. Variant 資料型態是所有沒被明確宣告為其他型
複製代碼

TOP

whirlwind963

帖子
29 
主題
7 
精華
0 
積分
42 
點名
0  
作業系統
XP 
軟體版本
OFFICE 2003 
閱讀權限
10 
註冊時間
2012-9-22 
最後登錄
2013-1-9 
29#
發表於 2012-12-15 11:17 | 只看該作者
回復 28# GBKEE
我看懂了~
感謝~
跟4#的程式碼差了一點
Private Sub 子資料夾(TheFolder)
    Dim fs As Object, f As Object
    Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(TheFolder)
=========================================================
    Private Sub 子資料夾(資料夾 As Variant)
        Dim fs  As Object, f As Variant
        Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(資料夾)
可以請問上面跟下面的差別嗎

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
28#
發表於 2012-12-15 10:56 | 只看該作者
回復 25# c_c_lai
Dim  f As Variant   這樣試試, 2007還有錯誤嗎?     

回復 27# whirlwind963
  1. Option Explicit
  2. Dim i As Integer, xCol As Integer
  3. Sub Ex()
  4.     Dim fs, f As Object, e As Object
  5.     Sheets(1).Activate
  6.     ActiveSheet.Pictures.Delete
  7.     Set fs = CreateObject("Scripting.FileSystemObject").GetFolder("D:\2012-12-12")
  8.     xCol = 3    '欄數
  9.     For Each e In fs.subfolders     '資料夾集合物件
  10.         i = 1                       '列數
  11.         子資料夾 e
  12.         xCol = xCol + 1             '欄數
  13.     Next
  14. End Sub
  15. Private Sub 子資料夾(資料夾 As Variant)
  16.     Dim fs  As Object, f As Variant
  17.     Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(資料夾)
  18.     For Each f In fs.Files    '檔案:集合物件
  19.         If UCase(f) Like "*.JPG" Or UCase(f) Like "*.GIF" Or UCase(f) Like "*.BMP" Then
  20.             i = i + 1
  21.             With ActiveSheet.Pictures.Insert(f)
  22.                 .Top = Cells(i, xCol).Top
  23.                 .Left = Cells(i, xCol).Left
  24.                 .Height = 49.5
  25.                 .Width = 49.5
  26.                 Cells(i, xCol).RowHeight = .Height
  27.                 Cells(i, xCol).ColumnWidth = .Width / 5.5
  28.             End With
  29.         End If
  30.     Next
  31.     For Each f In fs.subfolders     '資料夾:集合物件
  32.         i = i + 1
  33.         子資料夾 f                  '再度呼叫 (本程序)
  34.     Next
  35. End Sub
複製代碼

TOP

whirlwind963

帖子
29 
主題
7 
精華
0 
積分
42 
點名
0  
作業系統
XP 
軟體版本
OFFICE 2003 
閱讀權限
10 
註冊時間
2012-9-22 
最後登錄
2013-1-9 
27#
發表於 2012-12-15 09:19 | 只看該作者
回復 26# GBKEE
再問一個問題....
時間點的問題已解決
但是又遇到一個問題了
目前的巨集只能抓到指定時間點下面的圖片
如果裡面還有子資料夾
那怎麼辦呢

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
26#
發表於 2012-12-13 15:03 | 只看該作者
回復 25# c_c_lai
謝謝:上了一課

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
25#
發表於 2012-12-13 14:48 | 只看該作者
回復  c_c_lai
2003版 沒有錯誤!!
錯誤點 前  Debug.Print f   看看: 是哪個圖檔,將他刪掉試試
GBKEE 發表於 2012-12-13 12:09

測出癥結了，問題出在 f  變數之使用上：
  1.         With ActiveSheet.Pictures.Insert(f)
複製代碼
會出現 1004 的錯誤訊息，需修正為：
  1.         With ActiveSheet.Pictures.Insert(e & "\" & f.Name)
複製代碼
如此看來，For Each f In e.Files  的 f 在 2003 它可以當成字串直接處理，
而在 2010 時，  f 則視為一個物件 (Class)，此時如果直接使用它執行
With ActiveSheet.Pictures.Insert(f) 就會出現 1004 的錯誤訊息。

TOP

whirlwind963

帖子
29 
主題
7 
精華
0 
積分
42 
點名
0  
作業系統
XP 
軟體版本
OFFICE 2003 
閱讀權限
10 
註冊時間
2012-9-22 
最後登錄
2013-1-9 
24#
發表於 2012-12-13 14:18 | 只看該作者
回復 19# GBKEE
這次可以顯示出圖片了
感謝GBKEE大大的幫助

TOP

GBKEE

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

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

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
22#
發表於 2012-12-13 11:39 | 只看該作者
回復 21# GBKEE
  1. Option Explicit

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

供做測試用：   插入圖片2.rar (9.79 KB)

TOP

        靜思自在 : 不怕事多，只怕多事。
123
返回列表 上一主題