- 帖子
- 2833
- 主題
- 10
- 精華
- 0
- 積分
- 2889
- 點名
- 0
- 作業系統
- 〔略〕
- 軟體版本
- 〔略〕
- 閱讀權限
- 100
- 性別
- 男
- 來自
- 〔略〕
- 註冊時間
- 2013-5-13
- 最後登錄
- 2024-11-16
|
7#
發表於 2019-8-3 11:00
| 只看該作者
1) 看是3張圖???
2) 要學會使用上傳附檔, 方便別人下載
Sub 插人圖片()
Dim i%, P$, N$(3), xR As Range, xS, Shp As Shape
'路徑與資料夾檢測
P = ThisWorkbook.Path & "\客戶名稱圖檔"
If Dir(P, vbDirectory) = "" Then MsgBox "〔客戶名稱圖檔〕路徑錯誤或資料夾不存在! ": Exit Sub
For Each xR In [A3:C3]
If xR = "" Then MsgBox xR(0) & "未輸入! ": Exit Sub
If xR(0) <> "編號" Then P = P & "\" & xR Else N(0) = xR
If Dir(P, vbDirectory) = "" Then MsgBox "〔" & xR(0) & "〕路徑錯誤或資料夾不存在! ": Exit Sub
Next
'圖片檔案檢測
For i = 1 To 3
N(i) = N(0) & -i & ".jpg"
If Dir(P & "\" & N(i)) = "" Then MsgBox "找不到〔" & N(i) & "〕圖片檔案! ": Exit Sub
Next i
'載入圖檔並調整大小及位置
xS = Array("A11", "E11", "I11")
For i = 1 To 3
Set xR = Range(xS(i - 1)).Resize(9, 4) '圖片放置的範圍
Set Shp = ActiveSheet.Shapes.AddPicture(P & "\" & N(i), 0, 1, xR.Left, xR.Top, -1, -1)
If Shp.Height > xR.Height Then Shp.Height = xR.Height - 2 '調整圖片高度
If Shp.Width > xR.Width Then Shp.Width = xR.Width - 2 '調整圖片寬度
Shp.Top = xR.Top + (xR.Height - Shp.Height) / 2 '調整圖片上邊界(上下置中)
Shp.Left = xR.Left + (xR.Width - Shp.Width) / 2 '調整圖片左邊界(左右置中)
'Kill P & "\" & N(i) '刪除圖片檔案
Next i
End Sub
 TEST_v1.rar (1.63 MB)
======================================== |
|
發表於 2019-8-2 02:28
| 
