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 (1 người xem)

[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"

 

[giaiphap]

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 ạ?

Chứ code cũ của bạn nó có hợp lý đâu, khi chèn hình vào nó kéo thay đổi luôn tỷ lệ của hình. Còn nếu bạn muốn như code cũ của bạn thì giữ nguyên đoạn thay đổi kích thước hình (Cách này sẽ thay đổi kích thước không theo tỷ lệ hình gốc).

Sub INSERT_PIC()
    Dim MyMergeCell As Range
    Dim MyFile As String, shp As Shape
    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
    Set shp = ActiveSheet.Shapes.AddPicture(MyFile, msoFalse, msoCTrue, MyMergeCell.Left + 1, MyMergeCell.Top + 1, MyMergeCell.Width - 2, (MyMergeCell.Width / W) * H - 2)
    Select Case (MyMergeCell.Width / MyMergeCell.Height) / (shp.Width / shp.Height)
    Case Is > 1
        shp.Height = MyMergeCell.Height - 2
    Case Else
        shp.Width = MyMergeCell.Width - 2
    End Select
End Sub

Muốn hiển thị đúng luôn theo tỷ lệ ảnh gốc (cách này sẽ không làm biến dạng hình) thì chỉ cần thêm vào vài lệnh IF là xong (Cách này để bạn tự nghiên cứu vậy). Có thể tìm hiểu cách dùng lệnh chèn hình ở đây.

Shapes.AddPicture method (Excel)

Office VBA reference topic

learn.microsoft.com