Sửa code chèn ảnh vào cell tự động căn chỉnh (1 người xem)

[Trojan]

Chào các bác, tôi có copy được đoạn code như sau:

Sub Autofit_Picture()
Dim sFile As Variant, r As Range
sFile = Application.GetOpenFilename(FileFilter:="Pic Files (*.jpg;*.bmp), *.jpg;*.bmp", Title:="Browse to select a picture")
If sFile = False Then Exit Sub
On Error Resume Next
Set r = Application.InputBox("Hay lua chon vi tri chen anh", "Nguyen Duy Cong", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
If r.Count > 1 Then Exit Sub
ActiveSheet.Pictures.Insert (sFile)
With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
    .LockAspectRatio = False
    .Top = r.Top
    .Left = r.Left
    .Height = r.RowHeight
    .Width = r.Width
End With
End Sub

Mục đích là khi chèn ảnh vào 1 ô trong excel nó sẽ tự căn chỉnh để vừa đúng cell đó. Tuy nhiên vấn đề là khi ta chèn ảnh bình thường bằng thủ công copy file excel cho người khác thì vẫn có ảnh nhưng làm như trên thì khi copy file excel sẽ bị mất ảnh. Có cách nào sửa code để khi copy file excel vẫn còn hình ảnh trong file.
Chân thành cảm ơn.

 

[南宫飘雪]

Chào các bác, tôi có copy được đoạn code như sau:
Mục đích là khi chèn ảnh vào 1 ô trong excel nó sẽ tự căn chỉnh để vừa đúng cell đó. Tuy nhiên vấn đề là khi ta chèn ảnh bình thường bằng thủ công copy file excel cho người khác thì vẫn có ảnh nhưng làm như trên thì khi copy file excel sẽ bị mất ảnh. Có cách nào sửa code để khi copy file excel vẫn còn hình ảnh trong file.
Chân thành cảm ơn.

Sub Autofit_Picture()
  Dim sFile As Variant, r As Range
  Dim InsertPictrue As Picture
  
  sFile = Application.GetOpenFilename(FileFilter:="Pic Files (*.jpg;*.bmp), *.jpg;*.bmp", Title:="Browse to select a picture")
  If sFile = False Then Exit Sub
  On Error Resume Next
  Set r = Application.InputBox("Hay lua chon vi tri chen anh", "Nguyen Duy Cong", Type:=8)
  On Error GoTo 0
  If r Is Nothing Then Exit Sub
  If r.Count > 1 Then Exit Sub
  Set InsertPictrue = ActiveSheet.Pictures.Insert(sFile)
  If InsertPictrue Is Nothing Then Exit Sub
  With InsertPictrue
    .Copy
    .Delete
  End With
  Set InsertPictrue = ActiveSheet.Pictures.Paste
  If InsertPictrue Is Nothing Then Exit Sub
  With InsertPictrue.ShapeRange
    .LockAspectRatio = msoFalse
    .Top = r.Top
    .Left = r.Left
    .Height = r.RowHeight
    .Width = r.Width
  End With
  InsertPictrue.Placement = xlMoveAndSize '如果不需要图片位置大小与单元格总是保持一致，请删除这一行
End Sub