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

moihocvba · 2/2/23

Em chào anh chị ạ, em có tham khảo trên mạng được code chèn ảnh vào trong ô Excel, em nhờ anh chị chỉnh giúp em một vài chỗ ạ.

Mã:

Sub insertPhotoMacro()
Dim photoNameAndPath As Variant
Dim photo As Picture
photoNameAndPath = Application.GetOpenFilename(Title:="Select Photo to Insert")
If photoNameAndPath = False Then Exit Sub
Set photo = ActiveSheet.Pictures.Insert(photoNameAndPath)
With photo
.Left = ActiveSheet.Range("A1").Left
.Top = ActiveSheet.Range("A1").Top
.Width = ActiveSheet.Range("A1").Width
.Height = ActiveSheet.Range("A1").Height
.Placement = 1
End With
End Sub

E muốn khi chèn vào thì nó tự động căn giữa ô, và nó sẽ vừa trọn vào ô giống như hình ạ (Đối với hình dọc thì nó chèn vừa chiều cao của ô Excel, còn nếu hình ngang thì nó chèn vừa chiều rộng của ô Excel)

Em xin cám ơn anh chị rất nhiều ạ!

Hoàng Tuấn 868 · 3/2/23

Khả năng số người tự tạo file để thử là không nhiều.

moihocvba · 3/2/23

Hoàng Tuấn 868 đã viết:
Khả năng số người tự tạo file để thử là không nhiều.

Dạ em đã gửi file đính kèm ạ. Em cảm ơn anh!

huuthang_bd · 3/2/23

moihocvba đã viết:
E muốn khi chèn vào thì nó tự động căn giữa ô, và nó sẽ vừa trọn vào ô giống như hình ạ (Đối với hình dọc thì nó chèn vừa chiều cao của ô Excel, còn nếu hình ngang thì nó chèn vừa chiều rộng của ô Excel)

Đoạn màu đỏ sẽ mâu thuẫn với đoạn màu xanh.

moihocvba · 3/2/23

huuthang_bd đã viết:
Đoạn màu đỏ sẽ mâu thuẫn với đoạn màu xanh.

Dạ ý em là trọn 1 ô có thể theo chiều dọc hoặc chiều ngang mà kích thước nó không vượt ra khỏi ô ạ. Em gặp vấn đề ở đây là:
Khi em chèn vào ô nó sẽ sảy ra 2 trường hợp: Một là nó quá cao so với ô (với hình dọc), hai là nó quá dài so với chiều rộng ạ.
Em muốn khi chèn vào nó giống như hình mà em mô tả ở 2 trường hợp đó anh!
Cám ơn anh đã quan tâm!

Ví dụ có một hình ngang như thế này,như code trên khi em chèn vào anh thấy nó vượt ra khỏi ô A1

Em muốn khi chèn hình đó vào, nó sẽ như thế này:

befaint · 3/2/23

Vụ này có nhiều bài lắm rồi và mình cũng đưa code lên nhiều lần rồi.

Đây chỉ là kỹ thuật dàn trang, so sánh 2 tỉ lệ cao/rộng của khung chứa và của vật cần đặt vào khung. Lấy giấy bút ra giải toán một tẹo là xong, rồi đưa vào code thôi.

moihocvba · 3/2/23

befaint đã viết:
Vụ này có nhiều bài lắm rồi và mình cũng đưa code lên nhiều lần rồi.

Đây chỉ là kỹ thuật dàn trang, so sánh 2 tỉ lệ cao/rộng của khung chứa và của vật cần đặt vào khung. Lấy giấy bút ra giải toán một tẹo là xong, rồi đưa vào code thôi.

Dạ cám ơn anh, vậy anh cho em hỏi code gì để đặt nó căn giữa trên-dưới và giữa trái-phải của ô ạ?

befaint · 3/2/23

moihocvba đã viết:
giữa trên-dưới

Đặt theo Top: Giải bài toán dịch chuyển đường tâm của vật trùng tâm của khung hình = 1/2 cao khung - 1/2 cao vật

moihocvba đã viết:
giữa trái-phải

Đặt theo Left: làm như tương tự như trên.

Chỉ là một chút xíu hình học thôi mà.

HUONGHCKT · 3/2/23

moihocvba đã viết:
Em chào anh chị ạ, em có tham khảo trên mạng được code chèn ảnh vào trong ô Excel, em nhờ anh chị chỉnh giúp em một vài chỗ ạ.

Mã:

Sub insertPhotoMacro() Dim photoNameAndPath As Variant Dim photo As Picture photoNameAndPath = Application.GetOpenFilename(Title:="Select Photo to Insert") If photoNameAndPath = False Then Exit Sub Set photo = ActiveSheet.Pictures.Insert(photoNameAndPath) With photo .Left = ActiveSheet.Range("A1").Left .Top = ActiveSheet.Range("A1").Top .Width = ActiveSheet.Range("A1").Width .Height = ActiveSheet.Range("A1").Height .Placement = 1 End With End Sub

E muốn khi chèn vào thì nó tự động căn giữa ô, và nó sẽ vừa trọn vào ô giống như hình ạ (Đối với hình dọc thì nó chèn vừa chiều cao của ô Excel, còn nếu hình ngang thì nó chèn vừa chiều rộng của ô Excel)

View attachment 286053

Em xin cám ơn anh chị rất nhiều ạ!

Thử tham khảo xem file này ( của 1 anh thành viên của diễn đàn này (không nhớ tên- Hình như là Anh Ndu thì phải)

moihocvba · 3/2/23

befaint đã viết:
Đặt theo Top: Giải bài toán dịch chuyển đường tâm của vật trùng tâm của khung hình = 1/2 cao khung - 1/2 cao vật

Đặt theo Left: làm như tương tự như trên.

Chỉ là một chút xíu hình học thôi mà.

Dạ, vậy trong VBA nó không có thông số để chỉnh hình ảnh nằm giữa ô như Text hả anh?

Maika8008 · 3/2/23

moihocvba đã viết:
Em chào anh chị ạ, em có tham khảo trên mạng được code chèn ảnh vào trong ô Excel, em nhờ anh chị chỉnh giúp em một vài chỗ ạ.

E muốn khi chèn vào thì nó tự động căn giữa ô, và nó sẽ vừa trọn vào ô giống như hình ạ (Đối với hình dọc thì nó chèn vừa chiều cao của ô Excel, còn nếu hình ngang thì nó chèn vừa chiều rộng của ô Excel)

Em xin cám ơn anh chị rất nhiều ạ!

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

Rich (BB code):

'    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:\Pics\Box.jpg", Nothing, , True
(Lưu ý: dùng tham số True)

moihocvba · 3/2/23

Maika8008 đã viết:

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

Rich (BB code):

'    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:\Pics\Box.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 ạ!

befaint · 3/2/23

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.

Jayce · 4/2/23

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

moihocvba · 4/2/23

befaint đã viết:
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.

Em thấy nghiên cứu cái này cũng rất thú vị, cám ơn những gợi ý của anh befaint nhé!

moihocvba · 5/2/23

ChatGPT lợi hại quá ạ. Đúng với yêu cầu của em luôn.

Ronaldinho7 · 5/2/23

moihocvba đã viết:
ChatGPT lợi hại quá ạ. Đúng với yêu cầu của em luôn.

Hình như người dùng ở VN chưa thể đăng ký, bạn đăng ký ChatGPT bằng cách nào đấy?!

Dung.aof · 5/2/23

moihocvba đã viết:
ChatGPT lợi hại quá ạ. Đúng với yêu cầu của em luôn.

Nó có khả năng hiểu câu hỏi và tư duy giải quyết luôn, nhóm tạo ra quá giỏi luôn

Kiều Mạnh · 5/2/23

Hỏi ChatGPT nhiều cái rất hay... tuy nhiên nhiều cái không dùng được vì nó trả lời bao quát chung chung

Hổ trợ rất tốt cho ai đó đã từng biết code khi cần hỏi nó ... còn phức tạp chờ xem nó tiến hóa tới đâu

moihocvba · 5/2/23

Ronaldinho7 đã viết:
Hình như người dùng ở VN chưa thể đăng ký, bạn đăng ký ChatGPT bằng cách nào đấy?!

Mình mua tài khoản có sẵn trên mạng bán bạn ạ. Bạn vào trang divine shop mua, 100k/tài khoản, ko cần fake IP gì cả, rất ngon ạ!

Bài đã được tự động gộp: 5/2/23

Dung.aof đã viết:
Nó có khả năng hiểu câu hỏi và tư duy giải quyết luôn, nhóm tạo ra quá giỏi luôn

Đúng rồi bạn, mình không tin được nhân loại có thể tạo ra 1 ứng dụng như vậy. Quá siêu!

Bài đã được tự động gộp: 5/2/23

Kiều Mạnh đã viết:
Hỏi ChatGPT nhiều cái rất hay... tuy nhiên nhiều cái không dùng được vì nó trả lời bao quát chung chung

Hổ trợ rất tốt cho ai đó đã từng biết code khi cần hỏi nó ... còn phức tạp chờ xem nó tiến hóa tới đâu

Nó rất tiện lợi khi mình đang bế tắt trong công thức hoặc code vba, tuy nhiên mình phải hiểu để tùy biến lại code và lắp ghép lại thì mới sử dụng được. Tuy nhiên kết quả nó trả về rất tốt và đúng với câu hỏi của mình!

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

Thành viên thường trực

File đính kèm

Đăng ký hôm qua

Thành viên thường trực

Chuyên gia GPE

Thành viên thường trực

File đính kèm

|||||||||||||

Thành viên thường trực

|||||||||||||

Zalo 0986997214

File đính kèm

Thành viên thường trực

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

Thành viên thường trực

|||||||||||||

Thành viên mới

File đính kèm

Thành viên thường trực

Thành viên thường trực

Zl: 0707315985

Thành viên mới

I don't program, I beat code into submission!!!

Thành viên thường trực