Board logo

標題: 插入圖片時,等比例放大或縮小 [打印本頁]

作者: takeshilin88    時間: 2020-9-25 10:44     標題: 插入圖片時,等比例放大或縮小

請教插入圖片到儲存格範圍時,如何等比例的在儲存格範圍內放大或縮小
以下程式碼為圖片大小符合儲存格,應如何修改呢?

    i = ThisWorkbook.Path & "\" & NewRef & ".jpg"
    X = Dir(ThisWorkbook.Path & "\" & NewRef & ".jpg")
       If X <> "" Then
          Set rngs = Range(Cells(61, 2), Cells(61, 19))
          ActiveSheet.Shapes.AddPicture i, True, True, rngs.Left, rngs.Top, rngs.Width, rngs.Height
       Else
      End If

謝謝~~
作者: ikboy    時間: 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
複製代碼

作者: takeshilin88    時間: 2020-9-28 13:20

回復 2# ikboy


    感謝ikboy大大回覆,
    經測試後發現圖片有在儲存格內等比例放大,但似乎會停在10~15的這個迴圈出不來(因為等比例放大後的圖片寬度還是比儲存格範圍小),
    我試著在第13行插入Exit Sub,也沒有用,請問該如何修正?
    另外要加上什麼指令可以將等比例放大後的圖片在儲存格範圍內置中呢?
    謝謝~~
作者: ikboy    時間: 2020-9-28 17:17

我是基於你的代碼修改, 未參與迴圈部份, 不曉得問題所在。
作者: ikboy    時間: 2020-9-29 09:51

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

本帖最後由 takeshilin88 於 2020-9-29 15:21 編輯

回復 5# ikboy

ikboy大大您好:

是「圖自身長寬按相同比例盡量放入儲存格中」
您提供的指令有將圖片放大,但因為儲存格範圍比較寬,所以圖片還需要左右置中
謝謝
作者: ikboy    時間: 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
複製代碼

作者: takeshilin88    時間: 2020-9-30 15:07

回復 7# ikboy


    感謝ikboy大大,
    已經成功了,
    請教這裡的If的判斷是依照什麼條件,有點不太理解?? 高 / 寬
    If .Height / .Width >= Rngs.Height / Rngs.Width Then

    感恩~~
作者: ikboy    時間: 2020-9-30 22:44

那是計算儲存格與圖片高寬比, 選出適合的高或寬作為圖片的基礎然後......
作者: takeshilin88    時間: 2020-10-5 15:34

回復 9# ikboy


    原來如此,又學到了一招,再次感謝~~
作者: takeshilin88    時間: 2020-10-7 13:43

回復 7# ikboy

    求救!!!
    因此excel檔後續以巨集方式使用outlook寄信時,加入附件,
    但對方收到後檔案開啟無法正常顯示圖片,出現:無法顯示連結的圖像。檔案可能已移動、重新命名或刪除。請驗證連結指向正確的檔案及位置。

    查詢好像是要用Shapes.AddPicture 的方式,
    請教要如何改為Shapes.AddPicture 呢?
    感謝~
作者: ikboy    時間: 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
複製代碼

作者: takeshilin88    時間: 2020-10-8 14:51

回復 12# ikboy


    ikboy大大您好:
    看明明設定都沒錯,但是出來圖片的位置卻偏右邊耶,不知道是哪裡有問題?

[attach]32584[/attach]
作者: ikboy    時間: 2020-10-8 16:12

由於沒有圖片及附件做測試, 當中可能有Bug, 相信是第 9, 13 兩行的算法出問題。
作者: ikboy    時間: 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
複製代碼

作者: 准提部林    時間: 2020-10-8 18:49

Set rngs = Range(Cells(61, 2), Cells(61, 19))
With ActiveSheet.Shapes.AddPicture(i, False, True, rngs.Left, rngs.Top, True, True)
     .LockAspectRatio = msoFalse
     If .Width > rngs.Width - 4 Then .Width = rngs.Width - 4
     If .Height > rngs.Height - 4 Then .Height = rngs.Height - 4
     .Left = rngs.Left + (rngs.Width - .Width) / 2
     .Top = rngs.Top + (rngs.Height - .Height) / 2
End With
作者: ikboy    時間: 2020-10-10 11:14

喜歡准大這一句, 讚
  1. With ActiveSheet.Shapes.AddPicture(i, False, True, rngs.Left, rngs.Top, True, True)
複製代碼

作者: takeshilin88    時間: 2020-10-12 09:54

回復 16# 准提部林


    感謝准大的回覆,圖片已經有置中了,但是圖片沒有等比例的在儲存格範圍內放大或縮小呢?
    可以再幫忙指導一下嗎?
    謝謝~~
[attach]32604[/attach]
作者: 准提部林    時間: 2020-10-12 10:11

回復 18# takeshilin88


.LockAspectRatio = True
作者: takeshilin88    時間: 2020-10-12 10:43

回復 19# 准提部林


    似乎沒什麼變化....

[attach]32605[/attach]
作者: 准提部林    時間: 2020-10-12 10:55

回復 20# takeshilin88


.LockAspectRatio = msoTrue

.shaperange.LockAspectRatio = msoTrue


再不行的話, 要有檔案才能了解問題何在
作者: 准提部林    時間: 2020-10-12 10:58

回復 20# takeshilin88


或者, 原圖比存放位置小, 變成要"放大":
Set rngs = Range(Cells(61, 2), Cells(61, 19))
With ActiveSheet.Shapes.AddPicture(i, False, True, rngs.Left, rngs.Top, True, True)
     .LockAspectRatio = msoFalse
     .Width = rngs.Width - 4
     .Height = rngs.Height - 4
     .Left = rngs.Left + (rngs.Width - .Width) / 2
     .Top = rngs.Top + (rngs.Height - .Height) / 2
End With
作者: takeshilin88    時間: 2020-10-12 13:10

回復 22# 准提部林


    准大您好,
    因需要圖片放到儲存格範圍後能做到如下:
    1.圖片在儲存格範圍內「等比例」的放大or縮小,也就是接近儲存格範圍的大小(但不超出儲存格範圍)
    2.圖片在儲存格範圍內上下左右置中
    依照您的建議還是無法達成需求,已附上檔案,謝謝~~

[attach]32606[/attach]
作者: takeshilin88    時間: 2020-10-12 13:33

回復  准提部林


    准大您好,
    因需要圖片放到儲存格範圍後能做到如下:
    1.圖片在儲存格範 ...
takeshilin88 發表於 2020-10-12 13:10


   抱歉,更正一下檔案~~


[attach]32607[/attach]
作者: 准提部林    時間: 2020-10-12 14:37

本帖最後由 准提部林 於 2020-10-12 15:19 編輯

回復 24# takeshilin88

試了如圖:
[attach]32608[/attach]

Sub test()
Dim rngs As Range
Set rngs = [B61:S61]
With ActiveSheet.Shapes("圖片 1")
      .LockAspectRatio = True
      If .Width >= .Height Then .Width = rngs.Width - 4
      If .Height >= .Width Then .Height = rngs.Height - 4
      If .Width > rngs.Width - 4 Then .Width = rngs.Width - 4
      If .Height > rngs.Height - 4 Then .Height = rngs.Height - 4
      .Left = rngs.Left + (rngs.Width - .Width) / 2
      .Top = rngs.Top + (rngs.Height - .Height) / 2
End With
End Sub

'===============
作者: takeshilin88    時間: 2020-10-12 16:33

回復 25# 准提部林

    With ActiveSheet.Shapes("圖片 1")
    或設定為With ActiveSheet.Shapes(i)
    我在前面設定了
     i = ThisWorkbook.Path & "\" & NewRef & ".jpg"
   
    都會出現"找不到指定名稱的項目。
作者: takeshilin88    時間: 2020-10-12 17:16

回復 25# 准提部林


    剛剛試一下,把With ActiveSheet.Shapes("圖片 1")改成With ActiveSheet.Shapes.AddPicture(i, False, True, rngs.Left, rngs.Top, True, True)
    就可以了耶~~
    感謝准大,太感謝了~~




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)