Nhờ giúp đỡ đoạn code chèn ảnh trong excel 2010 (1 người xem)

[ali3340tc]

Chào các bác.

Cách đây khá lâu, tôi có nhờ các bác viết code để chèn ảnh tự động vào file.

http://www.giaiphapexcel.com/forum/showthread.php?25440-Chèn-hình-ảnh-tự-động-vào-excel&highlight=

Bình thường tôi chạy code này trên excel 2003 thì không vấn đề gì. Ảnh sau khi insert được full từ B12:O22
Bây giờ sử dụng file này cho excel 2010 thì hình ảnh không nằm trọn trong vùng B12:O22 nữa, hình ảnh sẽ theo kích thước thực của ảnh có thể bị vượt quá khung hình trên.
Nhờ các bác sửa dùm để sao cho chạy trên excel 2010 cũng giống như trên 2003. Thanks các bác.
Đoạn code:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Rng As Range, PicName As String
  Application.ScreenUpdating = False
  On Error Resume Next
  If Not Intersect([R2], Target) Is Nothing Then
    Set Rng = Sheet3.Range(Sheet3.[B1], Sheet3.[T65536].End(xlUp))
    PicName = Rng.Resize(, 1).Find(Target, LookAt:=xlWhole).Offset(, 20)
    ActiveSheet.Shapes("Pic").Delete
    With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & PicName)
     .Name = "Pic"
     .Left = [B12:O22].Left: .Top = [B12:O22].Top
     .Width = [B12:O22].Width: .Height = [B12:O22].Height
   End With
  End If
End Sub

 

[Hoàng Trọng Nghĩa]

Chào các bác.

Cách đây khá lâu, tôi có nhờ các bác viết code để chèn ảnh tự động vào file.

http://www.giaiphapexcel.com/forum/showthread.php?25440-Chèn-hình-ảnh-tự-động-vào-excel&highlight=

Bình thường tôi chạy code này trên excel 2003 thì không vấn đề gì. Ảnh sau khi insert được full từ B12:O22
Bây giờ sử dụng file này cho excel 2010 thì hình ảnh không nằm trọn trong vùng B12:O22 nữa, hình ảnh sẽ theo kích thước thực của ảnh có thể bị vượt quá khung hình trên.
Nhờ các bác sửa dùm để sao cho chạy trên excel 2010 cũng giống như trên 2003. Thanks các bác.
Đoạn code:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Rng As Range, PicName As String
  Application.ScreenUpdating = False
  On Error Resume Next
  If Not Intersect([R2], Target) Is Nothing Then
    Set Rng = Sheet3.Range(Sheet3.[B1], Sheet3.[T65536].End(xlUp))
    PicName = Rng.Resize(, 1).Find(Target, LookAt:=xlWhole).Offset(, 20)
    ActiveSheet.Shapes("Pic").Delete
    With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & PicName)
     .Name = "Pic"
     .Left = [B12:O22].Left: .Top = [B12:O22].Top
     .Width = [B12:O22].Width: .Height = [B12:O22].Height
   End With
  End If
End Sub

Tôi chưa test, nhưng tôi nghĩ chỉ cần thêm 1 thủ tục nữa chắc nó sẽ OK:

Private Sub Worksheet_Change(ByVal Target As Range)
      Dim Rng As Range, PicName As String
      Application.ScreenUpdating = False
      On Error Resume Next
      If Not Intersect([R2], Target) Is Nothing Then
            Set Rng = Sheet3.Range(Sheet3.[B1], Sheet3.[T65536].End(xlUp))
            PicName = Rng.Resize(, 1).Find(Target, LookAt:=xlWhole).Offset(, 20)
            ActiveSheet.Shapes("Pic").Delete
            With ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & PicName)
                  [COLOR=#ff0000][B].ShapeRange.LockAspectRatio = msoFalse[/B][/COLOR]
                  .Name = "Pic"
                  .Left = [B12:O22].Left: .Top = [B12:O22].Top
                  .Width = [B12:O22].Width: .Height = [B12:O22].Height
            End With
      End If
End Sub

 

[ali3340tc]

Thanks bác đã giúp đỡ. Còn 1 vấn đề nữa đó là:
Trong đoạn code này, khi R2 để trống thì trong excel 2003 sẽ không hiện hình ảnh nhưng trong excel 2010 thì nó báo là link bị thay đổi.
Mong các bác giúp đỡ thêm để khắc phục được lỗi này.

 

[ali3340tc]

File đính kèm là ảnh chụp báo lỗi của excel 2010. Ở excel 2003 thì không bị như vậy. Tôi phát hiện ra là: Khi insert ảnh mới vào, ảnh cũ không bị xoá đi. Nhờ các bác giúp đỡ. Tôi xin cảm ơn.