返回列表 上一主題 發帖

插入圖片時，等比例放大或縮小

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
0  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2025-3-24 

2016猴年全勤獎章
1# 跳轉到 »
發表於 2020-9-26 09:40 | 顯示全部帖子
建議增加宣告:
  1. Dim NewPicture as Object
複製代碼
  1. i = ThisWorkbook.Path & "\" & NewRef & ".jpg"
  2.     X = Dir(ThisWorkbook.Path & "\" & NewRef & ".jpg")
  3.     If X <> "" Then
  4.         Set Rngs = Range(Cells(61, 2), Cells(61, 19))
  5.         Set NewPicture = ActiveSheet.Pictures.Insert(i)
  6.         With NewPicture
  7.             .ShapeRange.LockAspectRatio = msoTrue
  8.             .Left = Rngs.Left
  9.             .Height = Rngs.Height
  10.             If .Width > Rng.Width Then
  11.                 .Width = Rng.Width
  12.                 .Top = Rngs.Top + (Rngs.Height - .Height) / 2
  13.             Else
  14.                 .Top = Rngs.Top
  15.             End If
  16.         End With
複製代碼

TOP

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
0  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2025-3-24 

2016猴年全勤獎章
2#
發表於 2020-9-28 17:17 | 顯示全部帖子
我是基於你的代碼修改, 未參與迴圈部份, 不曉得問題所在。

TOP

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
0  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2025-3-24 

2016猴年全勤獎章
3#
發表於 2020-9-29 09:51 | 顯示全部帖子
再看這一句 (因為等比例放大後的圖片寬度還是比儲存格範圍小) 後, 眼睛馬上@@, 腦裡??亂飛, 到底你要圖片剛填滿儲存格或圖自身長寬按相同比例盡量放入儲存格中?

TOP

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
0  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2025-3-24 

2016猴年全勤獎章
4#
發表於 2020-9-30 10:07 | 顯示全部帖子
由於衹是代碼片段修正案, 無法測試, 上次代碼中的Rngs, 欠了"s" 及沒有 End if, 此次一同修正。
  1. i = ThisWorkbook.Path & "\" & NewRef & ".jpg"
  2.     X = Dir(ThisWorkbook.Path & "\" & NewRef & ".jpg")
  3.     If X <> "" Then
  4.         Set Rngs = Range(Cells(61, 2), Cells(61, 19))
  5.         Set NewPicture = ActiveSheet.Pictures.Insert(i)
  6.         With NewPicture
  7.             .ShapeRange.LockAspectRatio = msoTrue
  8.             If .Height / .Width >= Rngs.Height / Rngs.Width Then
  9.                 .Height = Rngs.Height
  10.                 .Top = Rngs.Top
  11.                 .Left = (Rngs.Width - .Width) / 2 + Rngs.Left
  12.             Else
  13.                 .Width = Rngs.Width
  14.                 .Left = Rngs.Left
  15.                 .Top = (Rngs.Height - .Height) / 2 + Rngs.Top
  16.             End If
  17.         End With
  18.     End If
複製代碼

TOP

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
0  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2025-3-24 

2016猴年全勤獎章
5#
發表於 2020-9-30 22:44 | 顯示全部帖子
那是計算儲存格與圖片高寬比, 選出適合的高或寬作為圖片的基礎然後......

TOP

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
0  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2025-3-24 

2016猴年全勤獎章
6#
發表於 2020-10-7 17:25 | 顯示全部帖子
  1. i = ThisWorkbook.Path & "\" & NewRef & ".jpg"
  2.     X = Dir(ThisWorkbook.Path & "\" & NewRef & ".jpg")
  3.     If X <> "" Then
  4.         Set Rngs = Range(Cells(61, 2), Cells(61, 19))
  5.         Set NewPicture = ActiveSheet.Pictures.Insert(i)
  6.             xSize = .Height / .Width
  7.             If .Height / .Width >= Rngs.Height / Rngs.Width Then
  8.                 T = Rngs.Top
  9.                 L = (Rngs.Width - .Width) / 2 + Rngs.Left
  10.                 H = Rngs.Height
  11.                 W = H / xSize
  12.             Else
  13.                 T = (Rngs.Height - .Height) / 2 + Rngs.Top
  14.                 L = Rngs.Left
  15.                 W = Rngs.Width
  16.                 H = W * xSize
  17.             End If
  18.             .Delete
  19.         End With
  20.         Set NewPicture = ActiveSheet.Shapes.AddPicture(i, 1, 1, L, T, W, H)
  21.     End If
複製代碼

TOP

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
0  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2025-3-24 

2016猴年全勤獎章
7#
發表於 2020-10-8 16:12 | 顯示全部帖子
由於沒有圖片及附件做測試, 當中可能有Bug, 相信是第 9, 13 兩行的算法出問題。

TOP

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
0  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2025-3-24 

2016猴年全勤獎章
8#
發表於 2020-10-8 16:27 | 顯示全部帖子
修改以下一段試試, 但還是那一句, 沒有測試。
  1.     .ShapeRange.LockAspectRatio = msoTrue
  2.     xp = Rngs.Height / .Height
  3.     If .Height / .Width >= Rngs.Height / Rngs.Width Then
  4.         .Height = Rngs.Height
  5.         .Top = Rngs.Top
  6.         .Left = (Rngs.Width - .Width * xp) / 2 + Rngs.Left
  7.     Else
  8.         .Width = Rngs.Width
  9.         .Left = Rngs.Left
  10.         .Top = (Rngs.Height - .Height * xp) / 2 + Rngs.Top
  11.     End If
複製代碼

TOP

ikboy

帖子
262 
主題
8 
精華
0 
積分
280 
點名
0  
作業系統
xp 
軟體版本
Office 2007 
閱讀權限
20 
性別
男 
來自
HK 
註冊時間
2015-8-11 
最後登錄
2025-3-24 

2016猴年全勤獎章
9#
發表於 2020-10-10 11:14 | 顯示全部帖子
喜歡准大這一句, 讚
  1. With ActiveSheet.Shapes.AddPicture(i, False, True, rngs.Left, rngs.Top, True, True)
複製代碼

TOP

        靜思自在 : 【生命在呼吸間】佛陀說：「生命在呼吸間。」人無法管住自己的生命，更無法擋住死期，讓自己永住人間。既然生命去來這麼無常，我們更應該好好地愛惜它、利用它、充實它，讓這無常、寶貴的生命，散發它真善美的光輝，映照出生命真正的價值。
返回列表 上一主題