Xin code zoom image khi đưa click chuột vào hình ảnh

[pinklove]

Nhờ các bác giúp em cái code để khi em click chuột vào hình ảnh trong file thì nó phóng to lên để nhìn cho rõ hơn ạ. Em xin cảm ơn.

 

[pinklove]

Em đang cần, có bác nào giúp em được không ạ.

 

[Excel365]

Nhờ các bác giúp em cái code để khi em click chuột vào hình ảnh trong file thì nó phóng to lên để nhìn cho rõ hơn ạ. Em xin cảm ơn.

Bạn tham khảo hàm BS_PIC của addin Atools Link download: tại đây

 

[pinklove]

Bạn tham khảo hàm BS_PIC của addin Atools Link download: tại đây
View attachment 216570

Tham khảo thì nhìn thấy thế nhưng để áp dụng vào file em thì e ko làm được bác ạ

 

[Nguyễn Duy Tuân]

Tham khảo thì nhìn thấy thế nhưng để áp dụng vào file em thì e ko làm được bác ạ

Nếu đúng như bạn nói ở đầu bài thì hoàn toàn làm được nhé. Chỉ cần cài A-Tools, tại bảng tính, gõ hàm
=BS_PIC("đường dẫn file ảnh") ENTER
Bây giờ bấm chuột vào bức ảnh sẽ thấy.
Bạn xem video hướng dẫn nhanh tại đây

 

[pinklove]

Nếu đúng như bạn nói ở đầu bài thì hoàn toàn làm được nhé. Chỉ cần cài A-Tools, tại bảng tính, gõ hàm
=BS_PIC("đường dẫn file ảnh") ENTER
Bây giờ bấm chuột vào bức ảnh sẽ thấy.
Bạn xem video hướng dẫn nhanh tại đây

Cái này add nhiều ảnh 1 lúc thế có cách dòng ra để ghi chú như file em được ko anh. Và ảnh của em khi add vào nó cần nằm đúng vị trí của nó, chứ ko nằm lộn xộn được, nên em có tools add riêng. Dù em sắp xếp ảnh lộn xộn thì căn cứ vào tên ảnh là nó được add đúng vào vị trí. Chứ add kiều này thì ko được ạ.

 

[Hoàng Nhật Phương]

Bạn tham khảo thêm:

 

[pinklove]

Bạn tham khảo thêm:

Đúng ý mình rồi đó ạ. Cảm ơn bạn nhiều ạ.

 

[pinklove]

Bạn tham khảo thêm:

Mình thay code vào file khác nó báo thế này là do sao bạn???

 

[Hoàng Nhật Phương]

Mình thay code vào file khác nó báo thế này là do sao bạn???
View attachment 216806

Bạn vào Tools -> References và lựa chọn Microsoft Scripting Runtime từ trên danh sách để cài đặt -> nhấn OK.




Trong module của sheet1, OT sửa lại mấy chỗ bạn xem lại nhé.

Option Explicit

Private Sub Picture_Click()
    'https://www.mrexcel.com/forum/excel-questions/611678-macro-zoom-picture.html

    Static Dict As Dictionary
    Static MyPics() As Variant
    Static Cnt As Long
    Static c As Long
    Dim Shp As Shape
    Static SaveHeight As Single 'thêm dòng này
    Static SaveWidth As Single 'thêm dòng này
 
    Cnt = Cnt + 1
    If Cnt = 1 Then
        Set Dict = CreateObject("Scripting.Dictionary")
    End If
 
    Set Shp = Me.Shapes(Application.Caller)
    If Not Dict.Exists(Shp.Name) Then
        c = c + 1
        Dict.Add Shp.Name, c
        ReDim Preserve MyPics(1 To 2, 1 To c)
        MyPics(1, c) = Shp.Name
        MyPics(2, c) = True
    End If

    If MyPics(2, Dict.Item(Shp.Name)) = True Then
        MyPics(2, Dict.Item(Shp.Name)) = False

        'Ghi nhớ kích thước ảnh mặc định ban đầu
        SaveHeight = Shp.Height 'thêm dòng này
        SaveWidth = Shp.Width 'thêm dòng này
     
        Shp.ZOrder msoBringForward 'Chuyển dòng này lên đây
        Shp.Height = Shp.Height * 2 'thêm dòng này ----> phóng to 200%
        Shp.Width = Shp.Width * 2 'thêm dòng này ---->  phóng to 200%
 
'        Shp.ScaleHeight 1.5, msoTrue 'increase height by 50% ----> Xóa dòng này
'        Shp.ScaleWidth 1.5, msoTrue 'increase width by 50% ----> Xóa dòng này
     
    Else
        MyPics(2, Dict.Item(Shp.Name)) = True
'        Shp.ScaleHeight 1, msoTrue 'scale to original height ----> Xóa dòng này
'        Shp.ScaleWidth 1, msoTrue 'scale to original width ----> Xóa dòng này

        'Trả về kích thước ảnh mặc định ban đầu
        Shp.Height = SaveHeight 'thêm dòng này
        Shp.Width = SaveWidth 'thêm dòng này
    End If

End Sub

 

[pinklove]

Bạn vào Tools -> References và lựa chọn Microsoft Scripting Runtime từ trên danh sách để cài đặt -> nhấn OK.

View attachment 216809


Trong module của sheet1, OT sửa lại mấy chỗ bạn xem lại nhé.

Option Explicit

Private Sub Picture_Click()
    'https://www.mrexcel.com/forum/excel-questions/611678-macro-zoom-picture.html

    Static Dict As Dictionary
    Static MyPics() As Variant
    Static Cnt As Long
    Static c As Long
    Dim Shp As Shape
    Static SaveHeight As Single 'thêm dòng này
    Static SaveWidth As Single 'thêm dòng này

    Cnt = Cnt + 1
    If Cnt = 1 Then
        Set Dict = CreateObject("Scripting.Dictionary")
    End If

    Set Shp = Me.Shapes(Application.Caller)
    If Not Dict.Exists(Shp.Name) Then
        c = c + 1
        Dict.Add Shp.Name, c
        ReDim Preserve MyPics(1 To 2, 1 To c)
        MyPics(1, c) = Shp.Name
        MyPics(2, c) = True
    End If

    If MyPics(2, Dict.Item(Shp.Name)) = True Then
        MyPics(2, Dict.Item(Shp.Name)) = False

        'Ghi nhớ kích thước ảnh mặc định ban đầu
        SaveHeight = Shp.Height 'thêm dòng này
        SaveWidth = Shp.Width 'thêm dòng này
    
        Shp.ZOrder msoBringForward 'Chuyển dòng này lên đây
        Shp.Height = Shp.Height * 2 'thêm dòng này ----> phóng to 200%
        Shp.Width = Shp.Width * 2 'thêm dòng này ---->  phóng to 200%

'        Shp.ScaleHeight 1.5, msoTrue 'increase height by 50% ----> Xóa dòng này
'        Shp.ScaleWidth 1.5, msoTrue 'increase width by 50% ----> Xóa dòng này
    
    Else
        MyPics(2, Dict.Item(Shp.Name)) = True
'        Shp.ScaleHeight 1, msoTrue 'scale to original height ----> Xóa dòng này
'        Shp.ScaleWidth 1, msoTrue 'scale to original width ----> Xóa dòng này

        'Trả về kích thước ảnh mặc định ban đầu
        Shp.Height = SaveHeight 'thêm dòng này
        Shp.Width = SaveWidth 'thêm dòng này
    End If

End Sub

Vẫn lỗi bạn ạ. File gốc mình đây, bạn xem thử hộ mình.

 

[Hoàng Nhật Phương]

Vẫn lỗi bạn ạ. File gốc mình đây, bạn xem thử hộ mình.

Chào bạn,
OT kiểm tra thấy có một số hình ảnh bị che lấp do thứ tự đưa vào trước hoặc sau, bạn sửa giúp OT như sau nhé:

Xóa dòng này:

Shp.ZOrder msoBringForward 'Chuy?n dòng này lên dây

Thay bằng dòng này:

Shp.ZOrder msoBringToFront

Bạn tải lại file kèm nhé,
Chúc bạn ngon giấc!

 

[pinklove]

Chào bạn,
OT kiểm tra thấy có một số hình ảnh bị che lấp do thứ tự đưa vào trước hoặc sau, bạn sửa giúp OT như sau nhé:

Xóa dòng này:

Shp.ZOrder msoBringForward 'Chuy?n dòng này lên dây

Thay bằng dòng này:

Shp.ZOrder msoBringToFront

Bạn tải lại file kèm nhé,
Chúc bạn ngon giấc!

Cảm ơn bạn nhiều

 

[Nguyễn Duy Tuân]

Cái này add nhiều ảnh 1 lúc thế có cách dòng ra để ghi chú như file em được ko anh. Và ảnh của em khi add vào nó cần nằm đúng vị trí của nó, chứ ko nằm lộn xộn được, nên em có tools add riêng. Dù em sắp xếp ảnh lộn xộn thì căn cứ vào tên ảnh là nó được add đúng vào vị trí. Chứ add kiều này thì ko được ạ.

Add ảnh và hiển thị ở đâu là do mình chọn vùng. Cách thứ hai là dùng công thức. Chức năng này không phải làm lộn xộn và theo người sử dụng chỉ định, ô có thể nằm rời rạc hoặc bị mergecell. Nếu bạn có nhu cầu cao hơn với các tình huống khác như danh sách tìm kiếm có ảnh thì bạn xem kỹ về addin này..

 

[badboy.x9]

Chào bạn,
OT kiểm tra thấy có một số hình ảnh bị che lấp do thứ tự đưa vào trước hoặc sau, bạn sửa giúp OT như sau nhé:

Xóa dòng này:

Shp.ZOrder msoBringForward 'Chuy?n dòng này lên dây

Thay bằng dòng này:

Shp.ZOrder msoBringToFront

Bạn tải lại file kèm nhé,
Chúc bạn ngon giấc!

Mình copy code sang file khác nó báo lỗi vầy là sao vậy OT ?