Xin code chèn ảnh không bị lỗi "the linked image cannot displayer. The file name have been moved...."

Do Do Vjp pro · 1/10/21

Hi anh/ chị, gần đây công việc của em cần chèn nhiều ảnh vào file excel nhưng ko biết code VBA nên đành dùng record macro để chèn ảnh.
Tuy nhiên đến lúc xuất sang file .xlsx để gửi report đi, hoặc xóa ảnh đi thì bị hiện tượng như hình dưới:

Mong anh chị giúp đỡ dùng code để embedded ảnh luôn trong file .xlsx xuất ra với ạ
Em xin cảm ơn nhiều!

batman1 · 2/10/21

Do Do Vjp pro đã viết:
Hi anh/ chị, gần đây công việc của em cần chèn nhiều ảnh vào file excel nhưng ko biết code VBA nên đành dùng record macro để chèn ảnh.
Tuy nhiên đến lúc xuất sang file .xlsx để gửi report đi, hoặc xóa ảnh đi thì bị hiện tượng như hình dưới:

Bất cứ trong tập tin nào, khi muốn chèn ảnh thì gọi Sub InsertPicture.

Đọc giải thích để biết ý nghĩa của các tham số.

Nếu tham số cuối cùng LinkToFile = TRUE thì khi mang tập tin Excel đi bất cứ đâu cũng phải mang ảnh theo, nếu vẫn để "một chỗ" thì ảnh cũng không được phép xóa trên đĩa.

Bạn muốn xóa các ảnh trên đĩa hoặc không muốn mang các ảnh đi cùng tập tin Excel sang chỗ khác thì bắt buộc phải truyền LinkToFile = FALSE. Chú ý rằng LinkToFile = FALSE là mặc định (Optional) nên không cần truyền tường minh.

Mã:

Sub InsertPicture(ByVal PicFilename As String, Optional Target As range = Nothing, _
                Optional original As Boolean = False, Optional center As Boolean = False, _
                Optional LinkToFile As Boolean = False)
'    Target: vung nhap anh. Co the la nhieu cell
'    Neu Target = Nothing thi Target = ActiveCell
'    Neu original = True thi nhap anh kich thuoc thuc.
'    Neu original = FALSE thi neu center = True thi anh se center trong vung Target,
'    nguoc lai thi se vua khit vung Target
'    LinkToFile = False thi khong can giu anh tren dia, nguoc lai bat buoc phai giu anh de moi lan mo thi co
Dim w As Double, h As Double, shp As Shape, fso As Object
    If Target Is Nothing Then Set Target = ActiveCell
    On Error Resume Next
    Target.Parent.Shapes(Target.Address).Delete
    On Error GoTo 0
   
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    If fso.FileExists(PicFilename) Then
        If LinkToFile Then
            Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoTrue, msoFalse, Target.left, Target.top, 0, 0)
        Else
            Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoFalse, msoTrue, Target.left, Target.top, 0, 0)
        End If
        If Not shp Is Nothing Then
            With shp
                If original Then
                    .ScaleWidth 1, msoTrue
                    .ScaleHeight 1, msoTrue
                ElseIf center Then
                    .ScaleWidth 1, msoTrue
                    .ScaleHeight 1, msoTrue
                    w = Target.Width
                    h = w * .Height / .Width
                    If h > Target.Height Then
                        h = Target.Height
                        w = h * .Width / .Height
                    End If
                    .left = Target.left + (Target.Width - w) / 2
                    .top = Target.top + (Target.Height - h) / 2
                    .Width = w
                    .Height = h
                Else
                    .Width = Target.Width
                    .Height = Target.Height
                End If
                shp.Name = Target.Address
                shp.Placement = xlMoveAndSize
            End With
        End If
    End If
    
     Set fso = Nothing
 End Sub

Do Do Vjp pro · 2/10/21

batman1 đã viết:

Bất cứ trong tập tin nào, khi muốn chèn ảnh thì gọi Sub InsertPicture.

Đọc giải thích để biết ý nghĩa của các tham số.

Nếu tham số cuối cùng LinkToFile = TRUE thì khi mang tập tin Excel đi bất cứ đâu cũng phải mang ảnh theo, nếu vẫn để "một chỗ" thì ảnh cũng không được phép xóa trên đĩa.

Bạn muốn xóa các ảnh trên đĩa hoặc không muốn mang các ảnh đi cùng tập tin Excel sang chỗ khác thì bắt buộc phải truyền LinkToFile = FALSE. Chú ý rằng LinkToFile = FALSE là mặc định (Optional) nên không cần truyền tường minh.

Mã:

Sub InsertPicture(ByVal PicFilename As String, Optional Target As range = Nothing, _
                Optional original As Boolean = False, Optional center As Boolean = False, _
                Optional LinkToFile As Boolean = False)
'    Target: vung nhap anh. Co the la nhieu cell
'    Neu Target = Nothing thi Target = ActiveCell
'    Neu original = True thi nhap anh kich thuoc thuc.
'    Neu original = FALSE thi neu center = True thi anh se center trong vung Target,
'    nguoc lai thi se vua khit vung Target
'    LinkToFile = False thi khong can giu anh tren dia, nguoc lai bat buoc phai giu anh de moi lan mo thi co
Dim w As Double, h As Double, shp As Shape, fso As Object
    If Target Is Nothing Then Set Target = ActiveCell
    On Error Resume Next
    Target.Parent.Shapes(Target.Address).Delete
    On Error GoTo 0
  
    Set fso = CreateObject("Scripting.FileSystemObject")
  
    If fso.FileExists(PicFilename) Then
        If LinkToFile Then
            Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoTrue, msoFalse, Target.left, Target.top, 0, 0)
        Else
            Set shp = Target.Parent.Shapes.AddPicture(PicFilename, msoFalse, msoTrue, Target.left, Target.top, 0, 0)
        End If
        If Not shp Is Nothing Then
            With shp
                If original Then
                    .ScaleWidth 1, msoTrue
                    .ScaleHeight 1, msoTrue
                ElseIf center Then
                    .ScaleWidth 1, msoTrue
                    .ScaleHeight 1, msoTrue
                    w = Target.Width
                    h = w * .Height / .Width
                    If h > Target.Height Then
                        h = Target.Height
                        w = h * .Width / .Height
                    End If
                    .left = Target.left + (Target.Width - w) / 2
                    .top = Target.top + (Target.Height - h) / 2
                    .Width = w
                    .Height = h
                Else
                    .Width = Target.Width
                    .Height = Target.Height
                End If
                shp.Name = Target.Address
                shp.Placement = xlMoveAndSize
            End With
        End If
    End If
   
     Set fso = Nothing
 End Sub

Cảm ơn anh rất nhiều, nhưng đối với kẻ ngoại đạo như e đọc code thấy tù mù thật, e ngồi mày mò mãi ko ra

((
Anh có thể edit code trực tiếp trên file em gửi ko ạ, Em xin cảm ơn nhiều

batman1 · 2/10/21

Do Do Vjp pro đã viết:
Cảm ơn anh rất nhiều, nhưng đối với kẻ ngoại đạo như e đọc code thấy tù mù thật, e ngồi mày mò mãi ko ra ((
Anh có thể edit code trực tiếp trên file em gửi ko ạ, Em xin cảm ơn nhiều

Nếu bạn muốn tôi giúp tiếp thì phải mô tả cụ thể.
- Tên ảnh nhập vào mỗi ô lấy từ đâu. Vd. nhập vào B2 thì tên ảnh ở đâu? Đó là những ảnh định dạng gì, BMP, JPG?
- Các ảnh ở thư mục nào trên đĩa? Thư mục đó có nằm cùng thư mục với tập tin Excel không, tên là gì?
- Ảnh được nhập hàng loạt sau khi nhập tất cả các tên rồi nhấn nút hay cứ mỗi lần nhập xong một tên thì tự động nhập ảnh luôn.
- Đính kèm vài ảnh để test.

Do Do Vjp pro · 6/10/21

batman1 đã viết:
Nếu bạn muốn tôi giúp tiếp thì phải mô tả cụ thể.
- Tên ảnh nhập vào mỗi ô lấy từ đâu. Vd. nhập vào B2 thì tên ảnh ở đâu? Đó là những ảnh định dạng gì, BMP, JPG?
- Các ảnh ở thư mục nào trên đĩa? Thư mục đó có nằm cùng thư mục với tập tin Excel không, tên là gì?
- Ảnh được nhập hàng loạt sau khi nhập tất cả các tên rồi nhấn nút hay cứ mỗi lần nhập xong một tên thì tự động nhập ảnh luôn.
- Đính kèm vài ảnh để test.

Cảm ơn anh nhiệt tình giúp đỡ
e đã tìm được giải pháp rồi ạ

Mã:

Sub GetPic()
 Dim fNameAndPath As String
 Dim img As Excel.Shape
 
 ChDir ActiveWorkbook.Path
 fNameAndPath = (CurDir() & "\1.jpg")

 Set img = ActiveSheet.Shapes.AddPicture( _
  fNameAndPath, msoFalse, msoCTrue, ActiveSheet.Range("B15:F15").Left, _
  ActiveSheet.Range("B15:F15").Top, ActiveSheet.Range("B15:F15").Width, _
  ActiveSheet.Range("B15:F15").Height)
  img.LockAspectRatio = msoFalse

 End Sub

Xin code chèn ảnh không bị lỗi "the linked image cannot displayer. The file name have been moved...."

Do Do Vjp pro

Thành viên mới

File đính kèm

batman1

Thành viên gạo cội

Do Do Vjp pro

Thành viên mới

batman1

Thành viên gạo cội

Do Do Vjp pro

Thành viên mới

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng