12
返回列表 上一主題 發帖

[發問] 新手發問有關活頁中的圖片操作

baconbacons

帖子
36 
主題
6 
精華
0 
積分
50 
點名
0  
作業系統
windows xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2014-2-20 
最後登錄
2015-3-6 
1# 跳轉到 »
發表於 2014-4-3 17:38 | 只看該作者

Range( ) 中有變數 要再指定給物件變數的問題

以下程式碼目的是要將特定資料夾中的相片插入到指定儲存格並依儲存格大小調整相片尺寸
目前問題出在於「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
HELLO !!

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#
發表於 2014-4-3 20:50 | 只看該作者
回復 1# baconbacons
2003版可以的
  1. Option Explicit
  2. Sub ex()
  3.     Dim k, picNumRng As Range
  4.     For k = 1 To 50 'countPhoto                       '輸入相片編號
  5.         Set picNumRng = Range("A" & (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0)))
  6.         picNumRng.Select            
  7.     Next
  8. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

baconbacons

帖子
36 
主題
6 
精華
0 
積分
50 
點名
0  
作業系統
windows xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2014-2-20 
最後登錄
2015-3-6 
3#
發表於 2014-4-7 14:01 | 只看該作者
回復 2# GBKEE
GBKEE 大：
                     原先的程式碼本來在輸入編號就沒問題 只是在插入相片時會有錯誤產生
                     我將原始的程式碼改成你建議的方式 還是出現一樣的錯誤問題
                     還能怎麼修改呢？
HELLO !!

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#
發表於 2014-4-7 15:35 | 只看該作者
回復 3# baconbacons
我的2003版可以的需請有2010版的相助.
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

baconbacons

帖子
36 
主題
6 
精華
0 
積分
50 
點名
0  
作業系統
windows xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2014-2-20 
最後登錄
2015-3-6 
5#
發表於 2014-4-7 19:01 | 只看該作者
回復 4# GBKEE
請教 GBKEE 大：
你所謂的2003可以是指可以輸入流水編號，還是說連插入圖片也可以？
因為我執行你建議程式碼 只有選取符合的儲存格 最後停在k=50的那個儲存格

另外請教一個 For Each... Next 的觀念問題？
是否這個用法只針對「未運算執行巨集程式前」之「符合條件的所有物件集合」？
換言之 就是以我自己的這個例子來說
Set picNumRng = Range("A" & (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0)))
我的物件集合picNumRng是在For Next迴圈執行之後 才會「逐一」運算產生符合的物件
而不是在運算之前就已經完全得知所有的物件
在運用此種逐一產生的物件是否就必須再搭配For Next用法  而不是 For Each... Next
不知道這樣表達夠不夠清楚
HELLO !!

TOP

c_c_lai

帖子
2035 
主題
24 
精華
0 
積分
2031 
點名
0  
作業系統
Win7 
軟體版本
Office2010 
閱讀權限
100 
性別
男 
註冊時間
2012-3-22 
最後登錄
2024-2-1 
6#
發表於 2014-4-7 19:34 | 只看該作者
回復 5# baconbacons
試試這個：
  1. Sub Ex2()
  2.     Dim myFSO As New FileSystemObject
  3.     Dim myPath As String, myPic As Object
  4.     Dim myPhoto As String, countPhoto As Long       '  countPhoto As String
  5.     Dim picNumRng As Object
  6.     Dim k As Integer

  8.     myPath = ThisWorkbook.Path                                                                                            '  確認活頁簿所在路徑
  9.     countPhoto = myFSO.GetFolder(myPath & "\" & "原始相片").Files.Count          '  取得相片數量
  10.     myPhoto = Dir(myPath & "\" & "原始相片" & "\" & "*.jpg")
  11.    
  12.     If myPhoto <> "" Then                                                                                                           '  資料夾中有相片時複製表格
  13.         For k = 1 To countPhoto                                                                                                   '  輸入相片編號
  14.             Set picNumRng = Range("A" & (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0)))
  15.             
  16.             ActiveSheet.Pictures.Insert (myPath & "\" & "原始相片" & "\" & myPhoto)              '  插入與儲存格同名的相片檔
  17.             With ActiveSheet.Shapes(k)
  18.                 .LockAspectRatio = msoFalse
  19.                 .Top = picNumRng.Top
  20.                 .Left = picNumRng.Left
  21.                 .Width = 75
  22.                 .Height = 100
  23.             End With
  24.             myPhoto = Dir
  25.         Next
  26.     Else
  27.         MsgBox "資料夾中沒有相片"
  28.     End If
  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兔年全勤獎章
7#
發表於 2014-4-7 21:12 | 只看該作者
回復 5# baconbacons
  1. Option Explicit
  2. Sub Ex()
  3.     Dim E As Variant, K As Integer, picNumRng As Range
  4.     For Each E In Workbooks     'Workbook物件 的集合物件
  5.         MsgBox E.Name
  6.     Next
  7.     For Each E In Range("A5:C5") 'Cells物件 的集合物件
  8.         MsgBox E.Address
  9.     Next
  10.     For K = 1 To 50     '跑50次迴圈
  11.         Set picNumRng = Range("A" & (25 * (K - 1) + 5 - Application.WorksheetFunction.RoundUp((K - 1) / 2, 0)))
  12.         For Each E In picNumRng 'Cells物件 的集合物件
  13.             MsgBox E.Address
  14.         Next
  15.     Next
  16. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

baconbacons

帖子
36 
主題
6 
精華
0 
積分
50 
點名
0  
作業系統
windows xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2014-2-20 
最後登錄
2015-3-6 
8#
發表於 2014-4-7 22:53 | 只看該作者
回復 6# c_c_lai
c_c_lai 大：
經過修改後測試 確實可以執行 但是因為使用「ActiveSheet.Shapes(k)」的用法的關係
由於我在活頁中也設計了一個執行按鈕 所以這個用法會去抓這個按鈕的圖示 再貼到我指定儲存格
（如果沒有設計該按鈕的話 您所建議的程式碼確實都是可以符合我的需求的）
這個部分我比不知道怎麼改善 所以就試著使用GBKEE大的建議方法
不過 還是感謝c_c_lai 大的協助 讓我學到 .Shapes(k) 以及 myPhoto = Dir  的用法
感激…
HELLO !!

TOP

baconbacons

帖子
36 
主題
6 
精華
0 
積分
50 
點名
0  
作業系統
windows xp 
軟體版本
office 2010 
閱讀權限
20 
性別
男 
註冊時間
2014-2-20 
最後登錄
2015-3-6 
9#
發表於 2014-4-7 22:58 | 只看該作者
回復 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
   
    myPath = ThisWorkbook.Path                                                                                                          '確認活頁簿所在路徑
    myPhoto = Dir(myPath & "\" & "原始相片" & "\" & "*.jpg")                                                    '圖片檔路徑
    countPhoto = myFSO.GetFolder(myPath & "\" & "原始相片").Files.Count - 1                  '取得相片數量
    If myPhoto <> "" Then                                                                                                                         '資料夾中有相片時複製表格
        j = 50
        ActiveSheet.Cells(27, 3).Value = ActiveSheet.Cells(3, 3).Value
        ActiveSheet.Cells(28, 7).Value = ActiveSheet.Cells(4, 7).Value
        ActiveSheet.Cells(27, 7).Value = ActiveSheet.Cells(3, 7).Value
        ActiveSheet.Cells(27, 8).Value = ActiveSheet.Cells(3, 8).Value
        ActiveSheet.Cells(27, 10).Value = ActiveSheet.Cells(3, 10).Value
        ActiveSheet.Cells(27, 12).Value = ActiveSheet.Cells(3, 12).Value
        ActiveSheet.Cells(27, 14).Value = ActiveSheet.Cells(3, 14).Value
        
        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
HELLO !!

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#
發表於 2014-4-8 06:24 | 只看該作者
本帖最後由 GBKEE 於 2014-4-8 06:27 編輯

回復 9# baconbacons
Dim myFSO As New FileSystemObject
需設定 引用項目  Microsoft scripting runtime
  1. Option Explicit
  2. Sub Ex()
  3.     Dim myFSO As New FileSystemObject
  4.     Dim picNumRng As Range
  5.     Dim E As Variant, k As Integer, P As Object               
  6.     With ActiveSheet        '指定工作表
  7.         .Pictures.Delete    '刪除 所有相片
  8.         For Each P In myFSO.GetFolder("d:\相片\74年").Files         '檔案物件集合
  9.             If UCase(P) Like "*.JPG" Then    'P 檔案物件 傳回完整路徑名稱 , Like 比對是否有".JPG"的字元
  10.                 k = k + 1
  11.                 Set picNumRng = .Range("A" & (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0)))
  12.                 With picNumRng
  13.                     .Rows("1:1").RowHeight = 100                   '調整 高度
  14.                     .Columns("A:A").ColumnWidth = 25               '調整 寬度
  15.                 End With
  16.                 With .Pictures.Insert(P)                           '插入 P 檔案物件(相片)
  17.                     .ShapeRange.LockAspectRatio = msoFalse
  18.                     .Top = picNumRng.Top
  19.                     .Left = picNumRng.Left
  20.                     .Width = picNumRng.Width
  21.                     .Height = picNumRng.Height
  22.                 End With
  23.             End If
  24.         Next
  25.     End With
  26.     MsgBox "資料夾中" & IIf(k > 0, "共" & k & "張", "沒有") & "相片"
  27. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 天上最美是星星，人生最美是溫情。
12
返回列表 上一主題