Xin giúp vấn đề vba chèn hình nhưng người nhận file không nhìn thấy hình

[hungvm1505]

Xin phép các cao nhân kiểm tra giúp mình code sheet 1 và module 1.
Chẳng là mình thường xuyên làm báo cáo cần chèn nhiều hình ảnh và resize vừa khung merge.
Mình mò đến đoạn click vào ô nào thì Form button đi theo Target.Offset đến kế bên ô đó rồi.
Mình cũng chèn hình và hình được resize theo ô chọn rồi.
Nhưng mình save as pdf thì báo lỗi, hay là gửi trực tiếp file excel cho khách hàng thì họ không nhìn thấy hình ảnh.

Cảm ơn mọi người ạ!

 

[giaiphap]

Xin phép các cao nhân kiểm tra giúp mình code sheet 1 và module 1.
Chẳng là mình thường xuyên làm báo cáo cần chèn nhiều hình ảnh và resize vừa khung merge.
Mình mò đến đoạn click vào ô nào thì Form button đi theo Target.Offset đến kế bên ô đó rồi.
Mình cũng chèn hình và hình được resize theo ô chọn rồi.
Nhưng mình save as pdf thì báo lỗi, hay là gửi trực tiếp file excel cho khách hàng thì họ không nhìn thấy hình ảnh.

Cảm ơn mọi người ạ!View attachment 302058

Sửa code lại thế này xem sao.

Sub INSERT_PIC()
    Dim MyMergeCell As Range
    Dim MyFile As String
    Dim wia As Object, W As Double, H As Double
    If TypeName(Selection) <> "Range" Then Exit Sub
    Set MyMergeCell = Selection
    MyFile = Application.GetOpenFilename("Picture Files (*.bmp;*.jpg;*.tif;*.gif;*.png), *.bmp;*.jpg;*.tif;*.gif;*.png", , " GET PICTURE", , False)
    If MyFile = "False" Then Exit Sub
    Set wia = CreateObject("WIA.ImageFile")
    If wia Is Nothing Then Exit Sub
    wia.LoadFile MyFile
    W = wia.Width
    H = wia.Height
    Set wia = Nothing
    ActiveSheet.Shapes.AddPicture MyFile, msoFalse, msoCTrue, MyMergeCell.Left + 1, MyMergeCell.Top + 1, MyMergeCell.Width - 2, (MyMergeCell.Width / W) * H - 2
End Sub

 

[hungvm1505]

Sửa code lại thế này xem sao.

Sub INSERT_PIC()
    Dim MyMergeCell As Range
    Dim MyFile As String
    Dim wia As Object, W As Double, H As Double
    If TypeName(Selection) <> "Range" Then Exit Sub
    Set MyMergeCell = Selection
    MyFile = Application.GetOpenFilename("Picture Files (*.bmp;*.jpg;*.tif;*.gif;*.png), *.bmp;*.jpg;*.tif;*.gif;*.png", , " GET PICTURE", , False)
    If MyFile = "False" Then Exit Sub
    Set wia = CreateObject("WIA.ImageFile")
    If wia Is Nothing Then Exit Sub
    wia.LoadFile MyFile
    W = wia.Width
    H = wia.Height
    Set wia = Nothing
    ActiveSheet.Shapes.AddPicture MyFile, msoFalse, msoCTrue, MyMergeCell.Left + 1, MyMergeCell.Top + 1, MyMergeCell.Width - 2, (MyMergeCell.Width / W) * H - 2
End Sub

Em thử nhưng bị lỗi phần hình ảnh ko fit những ô lớn ạ. Khi fit ô lớn mà hình ảnh vuông thì nó lấn xuống page bên dưới luôn.
Về phần save và người nhận tải về thì có thể thấy hình ạ.
Cho e hỏi dòng code nào có ý nghĩa lưu hình như vậy ạ?

 

[thanhlanh]

Em thử nhưng bị lỗi phần hình ảnh ko fit những ô lớn ạ. Khi fit ô lớn mà hình ảnh vuông thì nó lấn xuống page bên dưới luôn.
Về phần save và người nhận tải về thì có thể thấy hình ạ.
Cho e hỏi dòng code nào có ý nghĩa lưu hình như vậy ạ?

Sao không lưu ảnh cùng thư mục rồi insert link (đường dẫn), khi bấm vào link sẽ hiện hình. Vd:

ActiveSheet.Hyperlinks.Add Anchor:=Selection, _
    Address:="D:\Cay canh\Bonsai1.jpg", _
    TextToDisplay:="D:\Cay canh\Bonsai1.jpg"