新手發問有關活頁中的圖片操作 - Excel程式區

帖子: 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版可以的

Option Explicit
Sub ex()
Dim k, picNumRng As Range
For k = 1 To 50 'countPhoto '輸入相片編號
Set picNumRng = Range("A" & (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0)))
picNumRng.Select
Next
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

帖子: 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 !!

帖子: 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元的贊助,人人有能力.

帖子: 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 !!

c_c_lai

博士班 Rank: 6 Rank: 6

帖子: 2035
主題: 24
精華: 0
積分: 2031
點名: 0
作業系統: Win7
軟體版本: Office2010
閱讀權限: 100
性別: 男
註冊時間: 2012-3-22
最後登錄: 2024-2-1

6^#

發表於 2014-4-7 19:34 | 只看該作者

回復 5# baconbacons
試試這個：

Sub Ex2()
Dim myFSO As New FileSystemObject
Dim myPath As String, myPic As Object
Dim myPhoto As String, countPhoto As Long ' countPhoto As String
Dim picNumRng As Object
Dim k As Integer
myPath = ThisWorkbook.Path ' 確認活頁簿所在路徑
countPhoto = myFSO.GetFolder(myPath & "\" & "原始相片").Files.Count ' 取得相片數量
myPhoto = Dir(myPath & "\" & "原始相片" & "\" & "*.jpg")
If myPhoto <> "" Then ' 資料夾中有相片時複製表格
For k = 1 To countPhoto ' 輸入相片編號
Set picNumRng = Range("A" & (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0)))
ActiveSheet.Pictures.Insert (myPath & "\" & "原始相片" & "\" & myPhoto) ' 插入與儲存格同名的相片檔
With ActiveSheet.Shapes(k)
.LockAspectRatio = msoFalse
.Top = picNumRng.Top
.Left = picNumRng.Left
.Width = 75
.Height = 100
End With
myPhoto = Dir
Next
Else
MsgBox "資料夾中沒有相片"
End If
End Sub

複製代碼

帖子: 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

Option Explicit
Sub Ex()
Dim E As Variant, K As Integer, picNumRng As Range
For Each E In Workbooks 'Workbook物件的集合物件
MsgBox E.Name
Next
For Each E In Range("A5:C5") 'Cells物件的集合物件
MsgBox E.Address
Next
For K = 1 To 50 '跑50次迴圈
Set picNumRng = Range("A" & (25 * (K - 1) + 5 - Application.WorksheetFunction.RoundUp((K - 1) / 2, 0)))
For Each E In picNumRng 'Cells物件的集合物件
MsgBox E.Address
Next
Next
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

帖子: 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 !!

帖子: 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 !!

帖子: 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

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"的字元
k = k + 1
Set picNumRng = .Range("A" & (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0)))
With picNumRng
.Rows("1:1").RowHeight = 100 '調整高度
.Columns("A:A").ColumnWidth = 25 '調整寬度
End With
With .Pictures.Insert(P) '插入 P 檔案物件(相片)
.ShapeRange.LockAspectRatio = msoFalse
.Top = picNumRng.Top
.Left = picNumRng.Left
.Width = picNumRng.Width
.Height = picNumRng.Height
End With
End If
Next
End With
MsgBox "資料夾中" & IIf(k > 0, "共" & k & "張", "沒有") & "相片"
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.