麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 如何插入資料夾中含子資料夾的圖片 [打印本頁]

作者: oxrain 時間: 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檔
請教各位前輩要如何加入呢？想說一個一個列，但會弄個好幾天，而且好笨...>.<
附上我的程式檔，麻煩各位賜教，我的頭快要爆了

Sub 插入圖片()
Dim modelno, modelno1, picins As String
Dim modelno2%
modelno = InputBox("A1請輸入A1、C6請輸入C6，以此類推", "輸入商品型號起始欄位", "")
picins = InputBox("插入A欄請輸入A、插入C欄請輸入C，以此類推", "輸入商品圖片插入欄位", "")
If modelno = "" Or picins = "" Then
MsgBox("末確實輸入")
Else
modelno1 = Left(modelno, 1)
modelno2 = Mid(modelno, 2, 3)
Columns("" & picins & ":" & picins & "").Select
Selection.ColumnWidth = 20
Rows("" & modelno2 & ":9999").Select
Selection.RowHeight = 50
Dim a%
Dim name As String
For a = modelno2 To 9999
name = Range("" & modelno1 & "" & a & "")
If name <> "" Then
Range("" & picins & "" & a & "").Select
If Dir("D:\PICTURE\001\" & name & ".jpg") <> "" Then
ActiveSheet.Pictures.Insert(P).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 49.5
Selection.ShapeRange.IncrementLeft 0.75
Else
Range("" & picins & "" & a & "") = "無圖片"
End If
End If
Next
End If
End Sub

複製代碼

作者: GBKEE 時間: 2011-9-28 16:55

回復 1# oxrain
試試看

Dim i As Integer
Sub Ex()
Dim fs, f, e As Variant
Sheets(1).Activate
ActiveSheet.Pictures.Delete
i = 1
For Each e In Array("D:\PIC0", "D:\PIC01")
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(e)
子資料夾 fs
Next
End Sub
Private Sub 子資料夾(TheFolder)
Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(TheFolder)
For Each f In fs.Files
If UCase(Mid(f, InStr(f, ".") + 1)) = "JPG" Then
With ActiveSheet.Pictures.Insert(f)
.Top = Cells(i, "A").Top
.Height = 49.5
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.IncrementLeft 0.75
End With
i = i + 5
End If
Next
For Each f In fs.SubFolders
子資料夾 f
Next
End Sub

複製代碼

作者: whirlwind963 時間: 2012-11-1 20:54

回復 2# GBKEE
請問
(1)可以選擇要從哪裡開始插入圖片嗎?例如C2開始
(2)我要10個圖就換一欄要怎麼用呢?

作者: GBKEE 時間: 2012-11-2 16:11

回復 3# whirlwind963

Dim i As Integer, xCol As Integer
Sub Ex()
Dim fs, f, e As Variant
Sheets(1).Activate
ActiveSheet.Pictures.Delete
'C2開始
i = 2 '列數
xCol = 3 '欄數
For Each e In Array("D:\相片")
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(e)
子資料夾 fs
Next
End Sub
Private Sub 子資料夾(TheFolder)
Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(TheFolder)
For Each f In fs.Files
If UCase(Mid(f, InStr(f, ".") + 1)) = "JPG" Then
With ActiveSheet.Pictures.Insert(f)
'.Top = Cells(i, "A").Top
.Top = Cells(i, xCol).Top
.Left = Cells(i, xCol).Left
.Height = 49.5
.Width = 49.5
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.IncrementLeft 0.75
End With
i = i + 5
If i >= 5 * 10 Then '10個圖就換一欄
xCol = xCol + 1
i = 2
End If
End If
Next
For Each f In fs.SubFolders
子資料夾 f
Next
End Sub

複製代碼

作者: whirlwind963 時間: 2012-11-2 19:35

回復 4# GBKEE
再請教一個問題
有辦法在C欄顯示圖片D欄顯示圖片的名稱嗎

作者: whirlwind963 時間: 2012-11-3 02:34

回復 4# GBKEE
請問如果我加入
Cells(i, xCol + 1) = f
取得檔案名稱
有辦法只取得檔案名稱
而不要完整的路徑嗎
EX:D:\圖片\ABC.JPG
我只要顯示ABC.JPG就好

作者: whirlwind963 時間: 2012-11-3 11:52

回復 2# GBKEE

如果改成
NN= cells(2,1)
MM=cells(3,1)
      For Each e In Array(NN,MM)
      Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(e)
      子資料夾 fs
Next
會出錯
請問有辦法自己在儲存格輸入位址嗎

作者: GBKEE 時間: 2012-11-3 15:06

回復 7# whirlwind963
5# 問 : C欄顯示圖片D欄顯示圖片的名稱你已在6# 自行解答,

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

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

作者: whirlwind963 時間: 2012-11-18 22:53

回復 4# GBKEE
請問一下
如果我有24個子資料夾
我想要
C1顯示子資料夾1的名稱C2顯示圖片
D1顯示子資料夾2的名稱D2顯示圖片
這樣的話該如何改呢

作者: GBKEE 時間: 2012-11-19 17:22

回復 9# whirlwind963
試試看

Option Explicit
Sub Ex()
Dim fs, f, e As Variant, i As Integer, xCol As Integer
Sheets(1).Activate
ActiveSheet.Pictures.Delete
xCol = 3 '欄數
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder("D:\相片")
For Each e In fs.subfolders '資料夾集合物件
i = 2 '列數
Cells(i, xCol) = e.Name
For Each f In e.Files '檔案集合物件
If UCase(Mid(f, InStr(f, ".") + 1)) = "JPG" Then
i = i + 1
With ActiveSheet.Pictures.Insert(f)
.Top = Cells(i, xCol).Top
.Left = Cells(i, xCol).Left
.Height = 49.5
.Width = 49.5
Cells(i, xCol).RowHeight = .Height
Cells(i, xCol).ColumnWidth = .Width / 5.5
End With
End If
Next
xCol = xCol + 1 '欄數
Next
End Sub

複製代碼

作者: whirlwind963 時間: 2012-12-11 22:29

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

作者: GBKEE 時間: 2012-12-12 08:35

回復 11# whirlwind963

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

複製代碼

作者: whirlwind963 時間: 2012-12-12 11:01

回復 12# GBKEE

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

作者: GBKEE 時間: 2012-12-12 11:55

回復 13# whirlwind963
這裡有改嗎?

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

複製代碼

作者: whirlwind963 時間: 2012-12-12 13:50

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

作者: whirlwind963 時間: 2012-12-12 16:38

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

作者: GBKEE 時間: 2012-12-12 20:21

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

作者: whirlwind963 時間: 2012-12-12 21:38

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

作者: GBKEE 時間: 2012-12-13 06:14

回復 18# whirlwind963

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

複製代碼

作者: c_c_lai 時間: 2012-12-13 11:00

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

Option Explicit
Sub Ex()
Dim fs As Object, f As Variant, e As Variant
Dim j As Integer, MyPath As String, MyFile As String
j = 2
MyPath = ActiveWorkbook.Path & "\My Pictures\"
Application.ScreenUpdating = False
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(MyPath)
For Each e In fs.subfolders ' 資料夾集合物件 e = "D:\Workspaces\DATA\Excel 範例集錦\TXT\2012-12-12\14"
' For Each f In e.Files ' 檔案集合物件 f = "D:\Workspaces\DATA\Excel 範例集錦\TXT\2012-12-12\14\Winter.jpg"
With Sheets("工作表1")
.Pictures.Delete
While Cells(j, "C") <> ""
If UCase(.Cells(j, "C")) Like "*ABCD*" Then '字串中有"ABCD"
'UCase 函數傳回一個 Variant (String)，所含為轉成大寫之字串。
.Cells(j, "D").Select
Selection.RowHeight = 100
Selection.ColumnWidth = 25
On Error Resume Next
' MyFile = Dir(e & "\*" & Cells(j, "C") & "*.*", vbDirectory)
MyFile = Dir(e & "\*" & Cells(j, "C") & "*.*")
If MyFile <> "" Then
' With .Pictures.Insert(MyPath & MyFile)
With .Pictures.Insert(e & "\" & MyFile)
.Top = Cells(j, "D").Top
.Left = Cells(j, "D").Left
.Height = 90
.Width = 120
.Cells(j, "D").RowHeight = .Height
.Cells(j, "D").ColumnWidth = .Width / 5.5
' .ShapeRange.LockAspectRatio = msoTrue
' 在調整圖案大小時，可以分別地調整圖案的長度和寬度
' .ShapeRange.LockAspectRatio = msoFalse
' .ShapeRange.Height = IIf(.ShapeRange.Height > 98, 98, .ShapeRange.Height)
' .ShapeRange.Width = IIf(.ShapeRange.Width > 150, 150, .ShapeRange.Width)
' .ShapeRange.Rotation = 0#
' .ShapeRange.IncrementLeft 2#
' .ShapeRange.IncrementTop 1#
' .Placement = xlMoveAndSize
' .PrintObject = True
End With
.Cells(j, "E") = MyFile
End If
End If
j = j + 1
Wend
.Range("C2").Select
End With
' Next ' For Each f In e.Files
Next ' For Each e In fs.subfolders
Application.ScreenUpdating = True
End Sub

複製代碼

作者: GBKEE 時間: 2012-12-13 11:11

本帖最後由 GBKEE 於 2012-12-13 11:15 編輯

回復 20# c_c_lai
程序中用 On Error Resume Next 有時會找不出錯誤點的
看一下 19#

' MyFile = Dir(e & "\*" & Cells(j, "C") & "*.*") 改用了
If UCase(f) Like "*.JPG" Or UCase(f) Like "*.GIF" Or UCase(f) Like "*.BMP" Then
'預防不是圖片檔

複製代碼

作者: c_c_lai 時間: 2012-12-13 11:39

回復 21# GBKEE

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

複製代碼

[attach]13510[/attach]
供做測試用： [attach]13511[/attach]

作者: GBKEE 時間: 2012-12-13 12:09

回復 22# c_c_lai
2003版沒有錯誤!!
錯誤點前 Debug.Print f 看看: 是哪個圖檔,將他刪掉試試

作者: whirlwind963 時間: 2012-12-13 14:18

回復 19# GBKEE
這次可以顯示出圖片了
感謝GBKEE大大的幫助

作者: c_c_lai 時間: 2012-12-13 14:48

回復 c_c_lai
2003版沒有錯誤!!
錯誤點前 Debug.Print f 看看: 是哪個圖檔,將他刪掉試試
GBKEE 發表於 2012-12-13 12:09

測出癥結了，問題出在 f 變數之使用上：

With ActiveSheet.Pictures.Insert(f)

複製代碼

會出現 1004 的錯誤訊息，需修正為：

With ActiveSheet.Pictures.Insert(e & "\" & f.Name)

複製代碼

如此看來，For Each f In e.Files 的 f 在 2003 它可以當成字串直接處理，
而在 2010 時， f 則視為一個物件 (Class)，此時如果直接使用它執行
With ActiveSheet.Pictures.Insert(f) 就會出現 1004 的錯誤訊息。

作者: GBKEE 時間: 2012-12-13 15:03

回復 25# c_c_lai
謝謝:上了一課

作者: whirlwind963 時間: 2012-12-15 09:19

回復 26# GBKEE
再問一個問題....
時間點的問題已解決
但是又遇到一個問題了
目前的巨集只能抓到指定時間點下面的圖片
如果裡面還有子資料夾
那怎麼辦呢

作者: GBKEE 時間: 2012-12-15 10:56

回復 25# c_c_lai
Dim f As Variant 這樣試試, 2007還有錯誤嗎?

回復 27# whirlwind963

Option Explicit
Dim i As Integer, xCol As Integer
Sub Ex()
Dim fs, f As Object, e As Object
Sheets(1).Activate
ActiveSheet.Pictures.Delete
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder("D:\2012-12-12")
xCol = 3 '欄數
For Each e In fs.subfolders '資料夾集合物件
i = 1 '列數
子資料夾 e
xCol = xCol + 1 '欄數
Next
End Sub
Private Sub 子資料夾(資料夾 As Variant)
Dim fs As Object, f As Variant
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(資料夾)
For Each f In fs.Files '檔案:集合物件
If UCase(f) Like "*.JPG" Or UCase(f) Like "*.GIF" Or UCase(f) Like "*.BMP" Then
i = i + 1
With ActiveSheet.Pictures.Insert(f)
.Top = Cells(i, xCol).Top
.Left = Cells(i, xCol).Left
.Height = 49.5
.Width = 49.5
Cells(i, xCol).RowHeight = .Height
Cells(i, xCol).ColumnWidth = .Width / 5.5
End With
End If
Next
For Each f In fs.subfolders '資料夾:集合物件
i = i + 1
子資料夾 f '再度呼叫 (本程序)
Next
End Sub

複製代碼

作者: whirlwind963 時間: 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(資料夾)
可以請問上面跟下面的差別嗎

作者: GBKEE 時間: 2012-12-15 11:35

回復 29# whirlwind963
是一樣的: 這引數 TheFolder 沒宣告型態就是 As Variant

Variant 資料型態
Variant 資料型態是所有沒被明確宣告為其他型

複製代碼

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)