插入圖片時，等比例放大或縮小 - Excel程式區 - 麻辣家族討論版版

麻辣家族討論版版 » Excel程式區 » 插入圖片時，等比例放大或縮小

返回列表下一主題上一主題發帖

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

中學生 Rank: 2

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

2016猴年全勤獎章

1^# 跳轉到 »

發表於 2020-9-26 09:40 | 顯示全部帖子

建議增加宣告:

Dim NewPicture as Object

複製代碼

i = ThisWorkbook.Path & "\" & NewRef & ".jpg"
X = Dir(ThisWorkbook.Path & "\" & NewRef & ".jpg")
If X <> "" Then
Set Rngs = Range(Cells(61, 2), Cells(61, 19))
Set NewPicture = ActiveSheet.Pictures.Insert(i)
With NewPicture
.ShapeRange.LockAspectRatio = msoTrue
.Left = Rngs.Left
.Height = Rngs.Height
If .Width > Rng.Width Then
.Width = Rng.Width
.Top = Rngs.Top + (Rngs.Height - .Height) / 2
Else
.Top = Rngs.Top
End If
End With

複製代碼

中學生 Rank: 2

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

2016猴年全勤獎章

2^#

發表於 2020-9-28 17:17 | 顯示全部帖子

我是基於你的代碼修改, 未參與迴圈部份, 不曉得問題所在。

中學生 Rank: 2

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

2016猴年全勤獎章

3^#

發表於 2020-9-29 09:51 | 顯示全部帖子

再看這一句 (因為等比例放大後的圖片寬度還是比儲存格範圍小) 後, 眼睛馬上@@, 腦裡??亂飛, 到底你要圖片剛填滿儲存格或圖自身長寬按相同比例盡量放入儲存格中?

中學生 Rank: 2

帖子: 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, 此次一同修正。

i = ThisWorkbook.Path & "\" & NewRef & ".jpg"
X = Dir(ThisWorkbook.Path & "\" & NewRef & ".jpg")
If X <> "" Then
Set Rngs = Range(Cells(61, 2), Cells(61, 19))
Set NewPicture = ActiveSheet.Pictures.Insert(i)
With NewPicture
.ShapeRange.LockAspectRatio = msoTrue
If .Height / .Width >= Rngs.Height / Rngs.Width Then
.Height = Rngs.Height
.Top = Rngs.Top
.Left = (Rngs.Width - .Width) / 2 + Rngs.Left
Else
.Width = Rngs.Width
.Left = Rngs.Left
.Top = (Rngs.Height - .Height) / 2 + Rngs.Top
End If
End With
End If

複製代碼

中學生 Rank: 2

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

2016猴年全勤獎章

5^#

發表於 2020-9-30 22:44 | 顯示全部帖子

那是計算儲存格與圖片高寬比, 選出適合的高或寬作為圖片的基礎然後......

中學生 Rank: 2

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

2016猴年全勤獎章

6^#

發表於 2020-10-7 17:25 | 顯示全部帖子

i = ThisWorkbook.Path & "\" & NewRef & ".jpg"
X = Dir(ThisWorkbook.Path & "\" & NewRef & ".jpg")
If X <> "" Then
Set Rngs = Range(Cells(61, 2), Cells(61, 19))
Set NewPicture = ActiveSheet.Pictures.Insert(i)
xSize = .Height / .Width
If .Height / .Width >= Rngs.Height / Rngs.Width Then
T = Rngs.Top
L = (Rngs.Width - .Width) / 2 + Rngs.Left
H = Rngs.Height
W = H / xSize
Else
T = (Rngs.Height - .Height) / 2 + Rngs.Top
L = Rngs.Left
W = Rngs.Width
H = W * xSize
End If
.Delete
End With
Set NewPicture = ActiveSheet.Shapes.AddPicture(i, 1, 1, L, T, W, H)
End If

複製代碼

中學生 Rank: 2

帖子: 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 兩行的算法出問題。

中學生 Rank: 2

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

2016猴年全勤獎章

8^#

發表於 2020-10-8 16:27 | 顯示全部帖子

修改以下一段試試, 但還是那一句, 沒有測試。

.ShapeRange.LockAspectRatio = msoTrue
xp = Rngs.Height / .Height
If .Height / .Width >= Rngs.Height / Rngs.Width Then
.Height = Rngs.Height
.Top = Rngs.Top
.Left = (Rngs.Width - .Width * xp) / 2 + Rngs.Left
Else
.Width = Rngs.Width
.Left = Rngs.Left
.Top = (Rngs.Height - .Height * xp) / 2 + Rngs.Top
End If

複製代碼

中學生 Rank: 2

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

2016猴年全勤獎章

9^#

發表於 2020-10-10 11:14 | 顯示全部帖子

喜歡准大這一句, 讚

With ActiveSheet.Shapes.AddPicture(i, False, True, rngs.Left, rngs.Top, True, True)

複製代碼

靜思自在 : 是非當教育，讚美作警惕。

返回列表下一主題上一主題