將多個圖片插入Excel並調整大小

imingho

這一支程式是因為網友來信問說在Excel中如果讓插入圖片時，可以跟word一樣會在表格內，試了一下Excel的插入圖片功能，好像都會顯示圖片原始大小尺寸，自己再把它縮小到您要的大小，這對於一次要在Excel中插入多張圖片時會很麻煩，所以就寫了這一支程式。

詳細說明: http://272586.blogspot.tw/2011/08/excel.html

修正記錄:
2013/03/05 加入圖片旋轉選項
2012/11/27 修正在Excel 2007版本以上(含)，圖片都會在貼在一塊

免費下載:http://download.bestdaylong.com/f107.htm

imingho

2013/8/24 程式碼

1. 
   
2. 
   
3. Private Sub cmdDelPic_Click()
   
4.     '將之前產生的圖片清除
   
5.     Sheet3.Activate
   
6.     Sheet3.Shapes.SelectAll
   
7.     Selection.Delete
   
8.     Sheet1.Activate
   
9.    
   
10.     MsgBox "刪除完成", vbOKOnly, "彰化一整天的blog(http://272586.blogspot.com)"
    
11. End Sub
    
12. 
    
13. Private Sub cmdMerge_Click()
    
14.     Dim a, b, c As Integer '宣告a,b,c為整數
    
15.    
    
16.     Dim objsheet As Worksheet
    
17.    
    
18.     WorkName = Excel.ActiveWorkbook.Name '此檔案名稱
    
19.    
    
20.   
    
21.     i = 6
    
22. 
    
23.     Z = 1
    
24.    
    
25.     picHeight = Range("b1")
    
26.     picWidth = Range("b2")
    
27.     picColumn = Range("b3")
    
28.     picAngle = Range("b4")
    
29.    
    
30.     '將之前產生的圖片清除
    
31.     Sheet3.Activate
    
32.     Sheet3.Shapes.SelectAll
    
33.     Selection.Delete
    
34.    
    
35.    
    
36.     While Sheet1.Range("b" & i) <> ""
    
37.    
    
38.         FilePath = Sheet1.Range("a" & i)
    
39.         Filename = Sheet1.Range("b" & i)
    
40.         
    
41.         If FilePath = "" Then
    
42.             Fullpath = Excel.Workbooks(WorkName).Path & "\" & Filename
    
43.         Else
    
44.             If Right(FilePath, 1) = "\" Then
    
45.                 Fullpath = FilePath & Filename
    
46.             Else
    
47.                 Fullpath = FilePath & "\" & Filename
    
48.             End If
    
49.         End If
    
50.         
    
51.         '檢查檔案是否存在
    
52.         If Dir(Fullpath) <> "" Then
    
53.         
    
54.             Sheet3.Activate
    
55.             
    
56.             Sheet3.Range(picColumn & Z).Select
    
57.             
    
58.             ActiveSheet.Pictures.Insert(Fullpath).Select
    
59.             
    
60.             
    
61.             If picHeight > 0 Then
    
62.                 Selection.ShapeRange.Height = 28.5 * picHeight
    
63. 
    
64.               '調整列高度
    
65.                Sheet3.Rows(Z).RowHeight = 28.5 * picHeight
    
66.                
    
67.           End If
    
68.             
    
69.             If picWidth > 0 Then
    
70.                 Selection.ShapeRange.Width = 28.5 * picWidth
    
71.             End If
    
72.             
    
73.             Selection.ShapeRange.Rotation = picAngle
    
74.             
    
75.             Selection.Cut   '2007才需要底下這樣作
    
76.             
    
77.             Sheet3.Range(picColumn & Z).Select
    
78.             
    
79.             ActiveSheet.Paste
    
80.         Else
    
81.             MsgBox "檔案:" & Fullpath & "不存在，請查看是否有拼錯字"
    
82.         End If
    
83.         i = i + 1 '讀取下一個名稱
    
84.         Z = Z + 1
    
85.     Wend
    
86.    
    
87.    
    
88.     MsgBox "執行完成", vbOKOnly, "彰化一整天的blog(http://272586.blogspot.com)"
    
89. 
    
90. End Sub
    

複製代碼

a3848654

hi 板主你好!!
最近因為工作上業務關西,想動手寫 vba 自動貼圖 但對一個門外漢來說 太吃力 想請問是否能請教你怎麼做??

我要做一個 例如:  我所指定的儲存格(B2,B3,)內的貼圖 會自己去抓A2,A3 內的數值當成圖片的檔名
貼上 該儲存格

但我一直抓不到頭緒 希望能幫我指引明燈

imingho

a3848654 發表於 2014-6-20 09:48
hi 板主你好!!
最近因為工作上業務關西,想動手寫 vba 自動貼圖 但對一個門外漢來說 太吃力 想請問是否能請 ...

該篇問題已在底下文章回覆.
想請教一下 自動貼圖的 VBA 問題
http://discuz.bestdaylong.com/fo ... 068&fromuid=424
(出處: 彰化一整天的論壇)