Tìm ảnh trùng nhau bằng VBA

MỹHạnhCB · 1/4/22

Chào các anh chị trong diễn đàn GPE.
Em muốn hỏi là trong VBA có thuật toán chạy kiểm tra hình ảnh giống nhau không ạ? Nếu có, có thể có em xin để tham khảo ạ. Em xin cảm ơn nhiều.
"Theo như yêu cầu là chạy thư mục chứa ảnh (1) -> So sánh ảnh trong thư mục (1) -> Phát hiện từ ảnh 2,3,4 bị trùng (giống nhau) -> Báo cáo kết quả ra Excel"

Maika8008 · 5/4/22

ToanNDQ đã viết:
Anh có thể cho em tham khảo được không ạ, Em áp vào nhưng bị báo lỗi ạ

Tôi nhân thêm hình thứ 8 nữa từ hình 7.JPG rồi chạy thủ tục TimHinhTrung. Kết quả chép vào ô C1 là đường dẫn đầy đủ của các file trùng (cần xóa đi)

MỹHạnhCB · 5/4/22

Maika8008 đã viết:
Tôi nhân thêm hình thứ 8 nữa từ hình 7.JPG rồi chạy thủ tục TimHinhTrung. Kết quả chép vào ô C1 là đường dẫn đầy đủ của các file trùng (cần xóa đi)

vâng cám ơn anh nhiều

Nhattanktnn · 6/4/22

Maika8008 đã viết:
Chạy ngon rồi bạn. Dùng thứ này so sánh là chắc ăn 100%, khỏi phải rắc rối cài đặt Python

Code #16 em chuyển thành Exe, Bác thử với exe này xem, mở file -> Chọn thư mục chứa ảnh -> ok (đang cài hoạt động với .jpg, .png, .jpeg)
https://drive.google.com/file/d/1P8jvHAFEd4y2CslWudqVuY7ZLrBH6zLX/view?usp=sharing

Maika8008 · 6/4/22

Nhattanktnn đã viết:
Code #16 em chuyển thành Exe, Bác thử với exe này xem, mở file -> Chọn thư mục chứa ảnh -> ok (đang cài hoạt động với .jpg, .png, .jpeg)
https://drive.google.com/file/d/1P8jvHAFEd4y2CslWudqVuY7ZLrBH6zLX/view?usp=sharing

Chạy ổn đấy bạn !

MỹHạnhCB · 9/4/22

Maika8008 đã viết:
Chạy ổn đấy bạn !

Nhờ anh xem giúp em, làm thế nào để khi dữ liệu gắn ra ô "A2" chỉ là những ảnh trùng nhau thôi ạ. Cám ơn anh

Maika8008 · 9/4/22

ToanNDQ đã viết:
Nhờ anh xem giúp em, làm thế nào để khi dữ liệu gắn ra ô "A2" chỉ là những ảnh trùng nhau thôi ạ. Cám ơn anh

Tôi chưa xem file bạn vì đang trên điện thoại.

Ý bạn là 2, 3, 4 trùng nhau thì phải liệt kê ra đủ, thay vì code của tôi ở bài #61 hoặc file exe của bài #63 kê ra file cần xóa 3 và 4 (vì trùng với 2)?

Nếu thế thì tôi chưa có giải pháp tối ưu.

MỹHạnhCB · 9/4/22

Maika8008 đã viết:
Tôi chưa xem file bạn vì đang trên điện thoại.

Ý bạn là 2, 3, 4 trùng nhau thì phải liệt kê ra đủ, thay vì code của tôi ở bài #61 hoặc file exe của bài #63 kê ra file cần xóa 3 và 4 (vì trùng với 2)?

Nếu thế thì tôi chưa có giải pháp tối ưu.

Dạ như bài #61 của anh thì do 1 thư mục của em có rất nhiều thư mục con và chứa rất nhiều hình (>10.000/1 thư mục) nên em không thể nhập (array) cho được ạ. Còn file ẽxe của bài #63 thì không liệt kê ra ễcl. Nên mong anh xem giúp e là liệt kê những ảnh trùng kèm đường dẫn thư mục lên excel ạ

Bài đã được tự động gộp: 9/4/22

ToanNDQ đã viết:
Dạ như bài #61 của anh thì do 1 thư mục của em có rất nhiều thư mục con và chứa rất nhiều hình (>10.000/1 thư mục) nên em không thể nhập (array) cho được ạ. Còn file ẽxe của bài #63 thì không liệt kê ra ễcl. Nên mong anh xem giúp e là liệt kê những ảnh trùng kèm đường dẫn thư mục lên excel ạ

Dạ theo như mục đích thì cũng tương tự như ở bài #61 nhưng là do chạy từng hình của từng thư mục con trong thư mục tổng nên em không biết sửa như thế nào.

Maika8008 · 9/4/22

ToanNDQ đã viết:
Dạ như bài #61 của anh thì do 1 thư mục của em có rất nhiều thư mục con và chứa rất nhiều hình (>10.000/1 thư mục) nên em không thể nhập (array) cho được ạ. Còn file ẽxe của bài #63 thì không liệt kê ra ễcl. Nên mong anh xem giúp e là liệt kê những ảnh trùng kèm đường dẫn thư mục lên excel ạ

Bạn trả lời tôi câu hỏi: bạn muốn kê ra 2, 3, 4 hay là chỉ 3, 4? (Như bài #66 tôi đã hỏi)

Yêu cầu khác nói sau

MỹHạnhCB · 9/4/22

Maika8008 đã viết:
Bạn trả lời tôi câu hỏi: bạn muốn kê ra 2, 3, 4 hay là chỉ 3, 4? (Như bài #66 tôi đã hỏi)

Yêu cầu khác nói sau

Dạ 2,3,4 trùng nhau. Thì liệt kê 3,4 ạ

Maika8008 · 9/4/22

ToanNDQ đã viết:
Dạ 2,3,4 trùng nhau. Thì liệt kê 3,4 ạ

OK bạn. Nếu thế thì đơn giản. Tôi đã hiểu hết những gì bạn muốn. Mai tôi sẽ gửi code cho bạn

MỹHạnhCB · 9/4/22

Maika8008 đã viết:
OK bạn. Nếu thế thì đơn giản. Tôi đã hiểu hết những gì bạn muốn. Mai tôi sẽ gửi code cho bạn

Vâng, cám ơn anh nhiều

Maika8008 · 10/4/22

ToanNDQ đã viết:
Vâng, cám ơn anh nhiều

Xem file. Sửa đường dẫn trong code.

MỹHạnhCB · 10/4/22

Maika8008 đã viết:
Xem file. Sửa đường dẫn trong code.

Cảm ơn anh nhé.
"ReDim aPic(1 To 10, 1 To 1)
ReDim aRes(1 To 10, 1 To 1)"
Nhưng 2 đoạn phần này em vẫn phải sửa mỗi khi số lượng ảnh thay đổi hả anh.

Maika8008 · 10/4/22

ToanNDQ đã viết:
Cảm ơn anh nhé.
"ReDim aPic(1 To 10, 1 To 1)
ReDim aRes(1 To 10, 1 To 1)"
Nhưng 2 đoạn phần này em vẫn phải sửa mỗi khi số lượng ảnh thay đổi hả anh.

Tôi quên sửa đó. Bạn cho 2 dòng Redim đó xuống vị trí trên For i... và khai báo Redim(1 to iR... (bằng với số lượng ảnh trong folder). Tôi chỉnh lại luôn như sau:

Rich (BB code):

Sub TimAnhTrung()
  Dim i&, j&, k&, EndR&, Path$, aPic, aRes
  Dim MyFile_Full As String
  Dim FSO As Object, dic As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set dic = CreateObject("Scripting.Dictionary")
    ReDim Arr(1 To 6000, 1 To 3)
    Path = "D:\TestGPE\HinhTest"   'Thay doi duong dan phu hop
    iR = 0
    ListFilesInFolder Path, True
    If Err.Number = 5 Then Exit Sub
    ReDim aPic(1 To iR, 1 To 1)
    ReDim aRes(1 To iR, 1 To 1)
    For i = 1 To iR
        aPic(i, 1) = FileToMD5Hex(Arr(i, 1) & "\" & Arr(i, 2))
        If Not dic.Exists(aPic(i, 1)) Then
            j = j + 1
            dic.Add aPic(i, 1), j
        Else
            k = k + 1
            aRes(k, 1) = Arr(i, 1) & "\" & Arr(i, 2)
        End If
    Next
    Set FSO = Nothing
    Set dic = Nothing
    Range("A2").Resize(10000, 1).ClearContents
    If k > 0 Then
        Range("A2").Resize(k, 1) = aRes
    Else
        MsgBox "Không có hình nào trùng."
    End If
End Sub

MỹHạnhCB · 10/4/22

Maika8008 đã viết:

Tôi quên sửa đó. Bạn cho 2 dòng Redim đó xuống vị trí trên For i... và khai báo Redim(1 to iR... (bằng với số lượng ảnh trong folder). Tôi chỉnh lại luôn như sau:

Rich (BB code):

Sub TimAnhTrung()
  Dim i&, j&, k&, EndR&, Path$, aPic, aRes
  Dim MyFile_Full As String
  Dim FSO As Object, dic As Object
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set dic = CreateObject("Scripting.Dictionary")
    ReDim Arr(1 To 6000, 1 To 3)
    Path = "D:\TestGPE\HinhTest"   'Thay doi duong dan phu hop
    iR = 0
    ListFilesInFolder Path, True
    If Err.Number = 5 Then Exit Sub
    ReDim aPic(1 To iR, 1 To 1)
    ReDim aRes(1 To iR, 1 To 1)
    For i = 1 To iR
        aPic(i, 1) = FileToMD5Hex(Arr(i, 1) & "\" & Arr(i, 2))
        If Not dic.Exists(aPic(i, 1)) Then
            j = j + 1
            dic.Add aPic(i, 1), j
        Else
            k = k + 1
            aRes(k, 1) = Arr(i, 1) & "\" & Arr(i, 2)
        End If
    Next
    Set FSO = Nothing
    Set dic = Nothing
    Range("A2").Resize(10000, 1).ClearContents
    If k > 0 Then
        Range("A2").Resize(k, 1) = aRes
    Else
        MsgBox "Không có hình nào trùng."
    End If
End Sub

Vâng, cám ơn a nhiều

Maika8008 · 10/4/22

ToanNDQ đã viết:
Vâng, cám ơn a nhiều

Bạn chạy thử rồi cho tôi (và tiện thể cho tác giả của bài #52) biết là tổng số file ảnh đã được duyệt qua là bao nhiêu và thời gian chạy khoảng bao nhiêu giây.

MỹHạnhCB · 10/4/22

Maika8008 đã viết:
Bạn chạy thử rồi cho tôi (và tiện thể cho tác giả của bài #52) biết là tổng số file ảnh đã được duyệt qua là bao nhiêu và thời gian chạy khoảng bao nhiêu giây.

máy công ty em chạy thử thì báo lỗi "Error --80131700", sao khi cài "Frame 2.0 and 3.0" thì tiếp tục báo lỗi "Error -- 80131509" ở dòng
"enc = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")" này anh. Hiện em chưa chạy thử được do nguồn dữ liệu đều nằm ở trên cty, còn trên laptop thì chạy bình thường nên em chưa biết xử lý sao ạ

Maika8008 · 10/4/22

ToanNDQ đã viết:
máy công ty em chạy thử thì báo lỗi "Error --80131700", sao khi cài "Frame 2.0 and 3.0" thì tiếp tục báo lỗi "Error -- 80131509" ở dòng
"enc = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")" này anh. Hiện em chưa chạy thử được do nguồn dữ liệu đều nằm ở trên cty, còn trên laptop thì chạy bình thường nên em chưa biết xử lý sao ạ

Bịnh này thì phải chờ bác sĩ :wallbash:

ongke0711 · 10/4/22

ToanNDQ đã viết:
máy công ty em chạy thử thì báo lỗi "Error --80131700", sao khi cài "Frame 2.0 and 3.0" thì tiếp tục báo lỗi "Error -- 80131509" ở dòng
"enc = CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")" này anh. Hiện em chưa chạy thử được do nguồn dữ liệu đều nằm ở trên cty, còn trên laptop thì chạy bình thường nên em chưa biết xử lý sao ạ

Frame 2.0 hay Net Framework 2.0?
Bạn kiếm bảng Net Framework mới nhất cài vô thử xem.

MỹHạnhCB · 10/4/22

ongke0711 đã viết:
Frame 2.0 hay Net Framework 2.0?
Bạn kiếm bảng Net Framework mới nhất cài vô thử xem.

em cài hết rồi á anh, xong chạy nó báo lỗi "Error -- 80131509" á

.Để thứ 3 em chụp ảnh gửi các anh chị xem thử giúp em, chứ laptop em chạy ok hết mà lên máy cty lại bị thì em cũng bó tay rồi ạ

Chúc anh chị cuối tuần vui vẻ

Tìm ảnh trùng nhau bằng VBA

Đi mây, về gió. !!!

File đính kèm

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

File đính kèm

Đi mây, về gió. !!!

Thành viên gắn bó

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

Đi mây, về gió. !!!

File đính kèm

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

Đi mây, về gió. !!!

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

Đi mây, về gió. !!!

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

Đi mây, về gió. !!!

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

File đính kèm

Đi mây, về gió. !!!

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

Đi mây, về gió. !!!

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

Đi mây, về gió. !!!

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

Thành viên gắn bó

Đi mây, về gió. !!!