[發問] EXCEL2010 批次匯入圖片,但不是用連結的方式

施建國

不好意思,之前有問過問題
我照著這裡的前輩修改,終於可以批次貼圖了
但後來發現是用連結的方式,我想要的是它是用複製貼上,然後符合儲存格大小

請問是要修改哪裡?謝謝各位前輩

1.     Sub ChangeSize()
   
2.         Dim Mypath As String, E As Range, MyPic As Object
   
3.         Mypath = "C:\Users\Administrator\Desktop\掉漆\O13\"
   
4.         With Sheets("O13")
   
5.             .Pictures.Delete
   
6.             For Each E In .Range("c3", .Range("c" & .Rows.Count).End(xlUp))
   
7.             'For Each  : 依序處裡集合的成員
   
8.             '集合的成員: .Range("a2") 到 .Range("a" & .Rows.Count).End(xlUp))的儲存格
   
9.                                          '(從最儲存格底部的列往到有資料的儲存格)
   
10.                 If Dir(Mypath & E & ".jpg") <> "" Then
    
11.                     Set MyPic = ActiveSheet.Pictures.Insert(Mypath & E & ".jpg")
    
12.                     With MyPic
    
13.                         .ShapeRange.LockAspectRatio = msoFalse
    
14.                         .Left = E.Cells(1, 1).Left
    
15.                         .Top = E.Cells(1, 1).Top
    
16.                         .Width = E.Cells(1, 1).Width
    
17.                         .Height = E.Cells(1, 1).Height
    
18.                     End With
    
19.                 End If
    
20.             Next
    
21.         End With
    
22.     End Sub

複製代碼

施建國

上網查到Shapes.AddPicture
但不知道如何取代

從已存在的檔案中建立圖片。傳回代表新圖片的 Shape 物件。
語法

ActiveSheet.AddPicture(Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height)

參數

名稱 必要/選用 資料類型 描述
Filename 必要 String 要建立 OLE 物件的來源檔案。
LinkToFile 必要 MsoTriState 要連結的檔案。
SaveWithDocument 必要 MsoTriState 要與文件一同儲存的圖片。
Left 必要 Single 圖片的左上角位置 (以點為單位)，與文件左上角相對。
Top 必要 Single 圖片的左上角位置 (以點為單位)，與文件頂端相對。
Width 必要 Single 圖片的寬度 (以點為單位)。
Height 必要 Single 圖片的高度 (以點為單位)。

傳回值 Shape

lpk187

回復 2# 施建國


   你上次這篇上，我的範例就有了啊！
http://forum.twbts.com/viewthread.php?tid=14275&rpid=78737&ordertype=0&page=1#pid78737

1. Private Sub Workbook_SheetActivate(ByVal Sh As Object)
   
2. If MsgBox("是否貼圖", 4) = vbNo Then Exit Sub
   
3. For Each shap In Sheets(Sh.Name).Shapes
   
4.     shap.Delete
   
5. Next
   
6. For Each Rng In Sheets(Sh.Name).Range("C3", Range("c3").End(xlDown))
   
7.     Pat = ThisWorkbook.Path & "\" & Sh.Name & "\" & Rng & ".jpg"
   
8.     Sheets(Sh.Name).Shapes.AddPicture Pat, True, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height
   
9. Next
   
10. End Sub

複製代碼

施建國

回復 3# lpk187


小弟試了幾天,還是弄不出來
謝謝大哥熱心回覆,請問我是哪裡做錯導致語法失敗呢??

下載 (115.93 KB)

2015-6-26 15:58

下載 (57.57 KB)

2015-6-26 15:59

下載 (105.65 KB)

2015-6-26 15:59

之後搜索一些圖片的語法,找到Hsieh前輩寫的自己選擇檔案貼上
我再把那一整欄剪下貼上,也是一種辦法

1. Sub InputPictures()
   
2. Dim fs(), A As Range
   
3. If ActiveSheet.Shapes.Count > 0 Then
   
4. ActiveSheet.Shapes.SelectAll
   
5. Selection.Delete
   
6. End If
   
7. On Error GoTo 10
   
8. fs = Application.GetOpenFilename("所有圖片(*.jpg;*.png;*.tiff;*.bmp;*.gif),*.jpg;*.png;*.tiff;*.bmp;*.gif", , , , True)
   
9. For i = 1 To UBound(fs)
   
10. Set A = Cells(i, 1)
    
11. A = fs(i)
    
12. With 工作表1.Shapes.AddPicture(fs(i), True, True, A.Offset(, 1).Left, A.Top, A.Offset(, 1).Width, A.Offset(, 1).Height)
    
13. .Placement = xlMoveAndSize
    
14. End With
    
15. Next
    
16. 10
    
17. End Sub

複製代碼

stillfish00

回復 4# 施建國
1錯了
    因為你之前圖片這樣放
    C:\Users\Administrator\Desktop\掉漆\O13\001.jpg

    那你Excel要放在
    C:\Users\Administrator\Desktop\掉漆\你的Excel檔案
    執行前要先選到 'O13' 這個工作表...

lpk187

回復 4# 施建國


   
我的程式碼放的位置如下圖，不管你的路徑在哪，只要如圖放就可以了

下載 (49.8 KB)

2015-6-26 17:18

然後開啟工作簿後，只要點選工作表就會問你是否貼上圖片，圖片的路徑會去尋找"這程式底下"的"資料夾"，
因你當初說的，會和資料夾會和工作表同名，例如：O13工作表會去找O13的資料夾，圖片名稱則是依照C欄的名稱去尋找圖片，

lpk187

回復 4# 施建國


    主要的路徑都在這列
Pat = ThisWorkbook.Path & "\" & Sh.Name & "\" & Rng & ".jpg"
ThisWorkbook.Path==>本檔案所在的資料夾
Sh.Name==>是工作表也是資料夾名稱
Rng & ".jpg"==>因為我假設你的圖片副檔名都為JPG檔，而Rng則是C欄的圖片主要檔名，若你的圖片不是JPG檔請自行更改。
會產生錯誤主要是你檔案或圖片放錯地方了，或者是副檔名不是JPG檔

施建國

回復 6# lpk187


照著你的方式打,在半夜成功了
是我一開始沒選到工作表
後來又自作聰明改工作表的名字試試看

謝謝lpk187前輩熱心點出我的錯誤
感恩~~~~

施建國

忘了說
lpk187前輩一開始寫的語法
已經完美的解決我的問題
是我自作聰明繞了一大圈
呵呵,想到就好笑
好在問題已經解決,可喜可賀