以下程式碼目的是要將特定資料夾中的相片插入到指定儲存格並依儲存格大小調整相片尺寸
目前問題出在於「Set picNumRng = Range("A" & (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0)))」
上述程式作用是依序於儲存格「A5,A29,A54,A78,A103,A127…」輸入相片流水號「1,2,3,4,5,6…」
執行後會出現執行階段錯誤「應用程式或物件定義上的錯誤」
監看了「Range(…) 」發現並不會呈現A5 所以也沒辦法指定給picNumRng
細看了一下 (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0))的結果確實是可以算出我需要的格數
但是與 Range("A" …) 無法結合成我需要的A5 是何原因？
--------------------------------------------------------------------------------------------
Sub photoConv()
Dim myFSO As New FileSystemObject
Dim myPath As String, myPic As Object
Dim E As Range, picNumRng As Object
Dim myPhoto As String, countPhoto As String
Dim i As Integer, j As Integer, k As Integer
myPath = ThisWorkbook.Path '確認活頁簿所在路徑
myPhoto = Dir(myPath & "\" & "原始相片" & "\" & "*.jpg")
countPhoto = myFSO.GetFolder(myPath & "\" & "原始相片").Files.Count - 1 '取得相片數量
If myPhoto <> "" Then '資料夾中有相片時複製表格
j = 50
For i = 1 To ((countPhoto + 1) \ 2 - 1)
Rows("1:49").Copy '複製表格
ActiveSheet.Paste Cells(j, 1)
j = j + 49
Next i
For k = 1 To countPhoto '輸入相片編號
Set picNumRng = Range("A" & (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0)))
picNumRng = k
For Each E In picNumRng '逐一處理儲存格
Set myPic = ActiveSheet.Pictures.Insert(myPath & E & ".jpg") '插入與儲存格同名的相片檔
With myPic
.ShapeRange.LockAspectRatio = msoFalse
.Left = E.Cells(1, 2).Left
.Top = E.Cells(1, 2).Top
.Width = E.Cells(1, 2).Width
.Height = E.Cells(1, 2).Height
End With
Next
Next
Else
MsgBox "資料夾中沒有相片"
End If
End Sub作者: GBKEE 時間: 2014-4-3 20:50
回復 7#GBKEE
GBKEE 大：
感謝清楚的範例解決我的觀念問題 我也利用這個小例子改善我原先的程式碼
確實已經可以執行了 萬分感謝
以下也貼上我修改後的程式碼 讓有需要的人也可以學習
如果能讓程式碼更簡潔的話 也請其他大大指教
----------------------------------------------------------------------------------------------
Sub photoConv1()
Dim myFSO As New FileSystemObject
Dim myPath As String
Dim picNumRng As Range, myPic As Object
Dim myPhoto As String, countPhoto As String
Dim E As Variant
Dim i As Integer, j As Integer, k As Integer
For i = 1 To ((countPhoto + 1) \ 2 - 1)
Rows("1:49").Copy '複製表格
ActiveSheet.Paste Cells(j, 1)
j = j + 49
Next i
For k = 1 To countPhoto
Set picNumRng = Range("A" & (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0)))
picNumRng = k '輸入相片編號
For Each E In picNumRng
Set myPic = ActiveSheet.Pictures.Insert(myPath & "\" & "原始相片" & "\" & E & ".jpg") '插入與儲存格同名的相片檔
With myPic
.ShapeRange.LockAspectRatio = msoFalse
.Top = picNumRng.Offset(0, 1).Top
.Left = picNumRng.Offset(0, 1).Left
.Width = picNumRng.Offset(0, 1).MergeArea.Width
.Height = picNumRng.Offset(0, 1).MergeArea.Height
End With
Next
Next k
Else
MsgBox "資料夾中沒有相片"
End If
Set picNumRng = Nothing
Set myPic = Nothing
End Sub作者: GBKEE 時間: 2014-4-8 06:24
本帖最後由 GBKEE 於 2014-4-8 06:27 編輯
回復 9#baconbacons
Dim myFSO As New FileSystemObject
需設定 引用項目 Microsoft scripting runtime
Option Explicit
Sub Ex()
Dim myFSO As New FileSystemObject
Dim picNumRng As Range
Dim E As Variant, k As Integer, P As Object
With ActiveSheet '指定工作表
.Pictures.Delete '刪除 所有相片
For Each P In myFSO.GetFolder("d:\相片\74年").Files '檔案物件集合
If UCase(P) Like "*.JPG" Then 'P 檔案物件 傳回完整路徑名稱 , Like 比對是否有".JPG"的字元
