頁:
[1]
VBA萬用字元收尋不到檔案時無法停止程式
請問一下各位大神!我想問一下!我這個程式碼只要在檔案夾內有所收尋的圖片都能正常執行，但當收尋的圖片不在資料夾內卻無法停止收巡，導致軟體會死當，有大大們可以幫我看看哪裡出了問題嗎?
Private Sub cmdMerge_Click()
Dim a, b, c As Integer '宣告a,b,c為整數
Dim objsheet As Worksheet
WorkName = Excel.ActiveWorkbook.Name '此檔案名稱
i = 6
Z = 1
picHeight = Range("d1")
picWidth = Range("d2")
picColumn = Range("d3")
picAngle = Range("d4")
'將之前產生的圖片清除
Sheet3.Activate
Sheet3.Shapes.SelectAll
Selection.Delete
While Sheet1.Range("d" & i) <> ""
FilePath = Sheet1.Range("c" & i)
Filename = Sheet1.Range("d" & i)
Set d = CreateObject("scripting.dictionary")
If FilePath = "" Then
FilePath = Excel.Workbooks(WorkName).Path
Else
If Right(FilePath, 1) = "\" Then
FilePath = FilePath
Else
FilePath = FilePath
End If
End If
txt = FilePath & "*" & Filename
File = Dir(txt)
Do While File <> ""
d(File) = ""
File = Dir()
Loop
'檢查檔案是否存在
For Each k In d.keys
If k Like "*" & Filename Then
Fullpath = FilePath & k
Sheet3.Activate
Sheet3.Range(picColumn & Z).Select
Set shpPic = Excel.ActiveSheet.Shapes.AddPicture(Fullpath, True, True, Selection.Left, Selection.Top, -1, -1)
If picHeight > 0 Then
shpPic.Height = 28.5 * picHeight
'調整列高度
Sheet3.Rows(Z).RowHeight = 28.5 * picHeight
End If
If picWidth > 0 Then
shpPic.Width = 28.5 * picWidth
End If
shpPic.Rotation = picAngle
Selection.Cut '2007才需要底下這樣作
Sheet3.Range(picColumn & Z).Select
ActiveSheet.Paste
Else
MsgBox "檔案:" & Fullpath & "不存在，請查看是否有拼錯字"
End If
i = i + 1 '讀取下一個名稱
Z = Z + 1
Exit For
Next
Wend
MsgBox "執行完成", vbOKOnly, ""
End Sub...<div class='locked'><em>瀏覽完整內容，請先 <a href='member.php?mod=register'>註冊</a> 或 <a href='javascript:;' onclick="lsSubmit()">登入會員</a></em></div><div></div> 本帖最後由 tvmateiii 於 2018-8-1 07:42 PM 編輯
你應該自己嘗試看看捉臭蟲
提示你
找不到檔案的時候
是否要跳出迴圈呢
你的 For Next 有好好配對嗎
我實在看不懂
Exit For 在 Next 止面代表什麼意思
＝＝＝＝＝＝＝＝＝＝＝
Exit For
Next
Wend
MsgBox "執行完成", vbOKOnly, ""
End Sub
＝＝＝＝＝＝＝＝＝＝＝
這是依照你上個問題提供的檔案去修改的，看是否符合你所需。Private Sub cmdMerge_Click()
Dim fs As Object, fd As Object, f As Object, b As Boolean, s As String
WorkName = Excel.ActiveWorkbook.Name '此檔案名稱
i = 6
Z = 1
picHeight = Range("b1")
picWidth = Range("b2")
picColumn = Range("b3")
picAngle = Range("b4")
'將之前產生的圖片清除
Sheet3.Activate
Sheet3.Shapes.SelectAll
Selection.Delete
'建立FileSystemObject物件
Set fs = CreateObject("Scripting.FileSystemObject")
While Sheet1.Range("b" & i) <> ""
Filepath = Sheet1.Range("a" & i)
Filename = Sheet1.Range("b" & i)
If Filepath = "" Then Filepath = Excel.Workbooks(WorkName).Path
Filepath = IIf(Right(Filepath, 1) = "\", Filepath, Filepath & "\")
'指定fd到Folder物件
Set fd = fs.GetFolder(Filepath)
'列舉出此資料夾所有檔案
b = False
For Each f In fd.Files
If f.Name Like "*" & Filename Then
Sheet3.Activate
Sheet3.Range(picColumn & Z).Select
Set shpPic = Excel.ActiveSheet.Shapes.AddPicture(f.Path, True, True, Selection.Left, Selection.Top, -1, -1)
If picHeight > 0 Then
shpPic.Height = 28.5 * picHeight
'調整列高度
Sheet3.Rows(Z).RowHeight = 28.5 * picHeight
End If
If picWidth > 0 Then shpPic.Width = 28.5 * picWidth
shpPic.Rotation = picAngle
Selection.Cut '2007才需要底下這樣作
Sheet3.Range(picColumn & Z).Select
ActiveSheet.Paste
b = True
Z = Z + 1
End If
Next
If Not b Then s = s & Filepath & "資料夾裡面找不到符合 *" & Filename & "的檔案!" & vbCrLf
i = i + 1 '讀取下一個名稱
Wend
MsgBox "執行完成" & IIf(s = "", "", vbCrLf & s)
End Sub...<div class='locked'><em>瀏覽完整內容，請先 <a href='member.php?mod=register'>註冊</a> 或 <a href='javascript:;' onclick="lsSubmit()">登入會員</a></em></div>
頁:
[1]