Code chèn ảnh vào vừa trong 1 ô Excel

One Response

1. hands says:

   03/02/2023 at 2:09 pm

   Code này là của anh Batman1. Bạn đọc kỹ rồi dùng nhé!

   '    Sub InsertPicture dung de chen anh. Khi can chen anh trong bat cu tap tin Excel nao thi can chen toan bo code cua Sub InsertPicture vao tap tin do.
   '    Cach su dung Sub InsertPicture y nhu trong code cua sheet DATA.
   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

   Ví dụ gọi sub để chèn ảnh có tên là Box.jpg trong thư mục D:Pics (đáp ứng yêu cầu của bạn) như sau:
   InsertPicture "D:PicsBox.jpg", Nothing, , True

   (Lưu ý: dùng tham số True)

   Dạ em cám ơn anh rất nhiều! Chúc anh nhiều vui trong cuộc sống ạ!

   Ai lại làm thế kia, hình méo mất, xấu òm.

   Người ta lock ratio lại. Sau khi đối chiếu tỉ lệ hai cạnh của 2 đối tượng thì chỉ cần thay đổi 1 trong 2 cạnh thôi.

   thử file này đi bạn. của bác gì đấy sau đó bác hoangtuan868 sửa lại chỉnh được nhiều ảnh cùng lúc

   Reply