彰化一整天的論壇

 找回密碼
 立即註冊
搜索
查看: 7530|回復: 4

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

[複製鏈接]
發表於 2012-11-27 14:21:15 | 顯示全部樓層 |閱讀模式
本帖最後由 imingho 於 2015-3-4 22:06 編輯

這一支程式是因為網友來信問說在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

insert_picture.xls

57 KB, 下載次數: 49

售價: 2 金錢  [記錄]

insert_picture.xls

回復

使用道具 舉報

 樓主| 發表於 2013-8-24 10:19:02 | 顯示全部樓層
2013/8/24 程式碼


  1. Private Sub cmdDelPic_Click()
  2.     '將之前產生的圖片清除
  3.     Sheet3.Activate
  4.     Sheet3.Shapes.SelectAll
  5.     Selection.Delete
  6.     Sheet1.Activate
  7.    
  8.     MsgBox "刪除完成", vbOKOnly, "彰化一整天的blog(http://272586.blogspot.com)"
  9. End Sub

  10. Private Sub cmdMerge_Click()
  11.     Dim a, b, c As Integer '宣告a,b,c為整數
  12.    
  13.     Dim objsheet As Worksheet
  14.    
  15.     WorkName = Excel.ActiveWorkbook.Name '此檔案名稱
  16.    
  17.   
  18.     i = 6

  19.     Z = 1
  20.    
  21.     picHeight = Range("b1")
  22.     picWidth = Range("b2")
  23.     picColumn = Range("b3")
  24.     picAngle = Range("b4")
  25.    
  26.     '將之前產生的圖片清除
  27.     Sheet3.Activate
  28.     Sheet3.Shapes.SelectAll
  29.     Selection.Delete
  30.    
  31.    
  32.     While Sheet1.Range("b" & i) <> ""
  33.    
  34.         FilePath = Sheet1.Range("a" & i)
  35.         Filename = Sheet1.Range("b" & i)
  36.         
  37.         If FilePath = "" Then
  38.             Fullpath = Excel.Workbooks(WorkName).Path & "\" & Filename
  39.         Else
  40.             If Right(FilePath, 1) = "\" Then
  41.                 Fullpath = FilePath & Filename
  42.             Else
  43.                 Fullpath = FilePath & "\" & Filename
  44.             End If
  45.         End If
  46.         
  47.         '檢查檔案是否存在
  48.         If Dir(Fullpath) <> "" Then
  49.         
  50.             Sheet3.Activate
  51.             
  52.             Sheet3.Range(picColumn & Z).Select
  53.             
  54.             ActiveSheet.Pictures.Insert(Fullpath).Select
  55.             
  56.             
  57.             If picHeight > 0 Then
  58.                 Selection.ShapeRange.Height = 28.5 * picHeight

  59.               '調整列高度
  60.                Sheet3.Rows(Z).RowHeight = 28.5 * picHeight
  61.                
  62.           End If
  63.             
  64.             If picWidth > 0 Then
  65.                 Selection.ShapeRange.Width = 28.5 * picWidth
  66.             End If
  67.             
  68.             Selection.ShapeRange.Rotation = picAngle
  69.             
  70.             Selection.Cut   '2007才需要底下這樣作
  71.             
  72.             Sheet3.Range(picColumn & Z).Select
  73.             
  74.             ActiveSheet.Paste
  75.         Else
  76.             MsgBox "檔案:" & Fullpath & "不存在,請查看是否有拼錯字"
  77.         End If
  78.         i = i + 1 '讀取下一個名稱
  79.         Z = Z + 1
  80.     Wend
  81.    
  82.    
  83.     MsgBox "執行完成", vbOKOnly, "彰化一整天的blog(http://272586.blogspot.com)"

  84. End Sub
複製代碼
回復 支持 反對

使用道具 舉報

發表於 2014-6-20 09:48:28 | 顯示全部樓層
hi 板主你好!!
最近因為工作上業務關西,想動手寫 vba 自動貼圖 但對一個門外漢來說 太吃力 想請問是否能請教你怎麼做??

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

但我一直抓不到頭緒 希望能幫我指引明燈
回復 支持 反對

使用道具 舉報

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

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

使用道具 舉報

您需要登錄後才可以回帖 登錄 | 立即註冊

本版積分規則

 ㄚ母滴雞湯
 員林香純滴雞精

Archiver|手機版|小黑屋|彰化一整天的論壇(Excel,Office)  |网站地图

GMT+8, 2017-10-17 14:13 , Processed in 0.057252 second(s), 17 queries , Apc On.

Powered by Discuz! X3.2

© 2001-2013 Comsenz Inc.

快速回復 返回頂部 返回列表