Tìm kiếm các file Excel có chứa macro

Trạng thái
Không mở trả lời sau này.

Binana

Thành viên mới
Chào các anh chị trên diễn đàn
Hiện tại em có vấn đề như sau:
Do lang thang trên mạng đọc em có tải về rất nhiều những file excell mà em cảm thấy hay, trong có cả những file chứa macro và những file không chứa macro

Vấn đề ở đây. Bây giờ em muốn tìm kiếm những file có chứa macro đưa nó sang 1 foder mới và những file không chứa macro sang 1 foder.
Cái này liệu có khả thi không ạ.
Rất mong được mọi người giúp đỡ. Em cám ơn.
 

tuhocvba

Administrator
Thành viên BQT
Cái này khả thi trong trường hợp mà file của họ không khóa Project. Chứ nếu khóa Project thì lại quay về bài toán UnProtect, mệt lắm bạn ạ. Lúc đó bài toán sẽ trở nên phức tạp.
Cho nên cần làm rõ vấn đề, là các file của bạn có khóa Project hay không.
 

vanthanhVBA

Thành viên
Bạn nghiên cứu Tool này thử xem nhé. Mình chưa thử và cũng chưa có thời gian việt hóa.
Link download:
Nguồn:
Sheet ngoài cùng bên trái ở dòng 23 có ghi là có thực hiện chuẩn đoán file có VBA hay không.
Mình chưa thử là với file macro bị khóa Protect kiểu như Unviewable hoặc ẩn Module thì nó có thực hiện chuẩn đoán được hay không , mới chỉ thử khóa Protect thông thường thì file vẫn thực hiện chuẩn đoán được, cho ra kết quả là 1.

Để sử dụng thì bạn mở file cần kiểm tra lên và ấn nút chuẩn đoán phía trên cùng của file tool (sheet ngoài cùng bên trái).
Tham khảo code của họ và tự thực hiện nhé.
 

Binana

Thành viên mới
@tuhocvba . Cám ơn anh đã phản hồi. Thực ra trường hợp trường hợp như anh nói . Đúng là em không để ý. Chẳng hạn những file nào mà bị khóa Project có thể bẫy lỗi bỏ qua được không ạ. Chứ giờ mở từng file xem thằng nào bị khóa Project thì cũng quay lại bài toán từ đầu mất.
 

USA_Covid19

Thành viên tích cực
Theo kinh nghiệm phá phách của mình thì việc này không phụ thuộc vào việc khóa hay không khóa vẫn biết được :
-Trình tự code như sau :
+Nén file cần xác định có chứa macro hay ko
+Giải nén tìm file vbaproject.bin
+Nếu có thì file chứa macro và ngược lại
 

tuhocvba

Administrator
Thành viên BQT
Giỏi. usa thực hiện cho bạn ấy và lấy tiền tài trợ cho diễn đàn đi.
 

BKKBG

Thành viên
Bạn thử, chạy thủ tục test, sửa lại đường link file.
Mã:
'=================================================
' Thong tin ung ho dien dan
'Ngan hang thuong mai co phan ngoai thuong viet nam vietcombank, so tai khoan: 0011003264055
'Chi nhanh quan Hoan Kiem, Ha Noi
'Chu tai khoan: Pham Minh Hoang
'=================================================
'INPUT: Workbook can kiem tra
'OUTPUT:
'0: Normal
'1:Macro have  been disabled
'2:Project Protected
'3: Have macro (normal, not protect)


Function GetVBAProject(wb As Workbook) As Byte   ''Dieu tra mot file co macro hay khong
    Dim i As Long, flag As Boolean, buf As String
    GetVBAProject = 0
    On Error Resume Next
    buf = wb.VBProject.Name
    On Error GoTo 0
    If buf = "" Then
        GetVBAProject = 1 'Macro have  been disabled
        Exit Function
    End If
    On Error Resume Next
    i = wb.VBProject.VBComponents.Count
    On Error GoTo 0
    If i = 0 Then
        GetVBAProject = 2
        Exit Function
    End If
    If Not wb.HasVBProject Then
        GetVBAProject = 0
    Else
        GetVBAProject = 3
    End If
 
End Function

Sub test()
    Dim lk  As String
    Dim wbn As String
    Dim i   As Byte
   
    lk = "file:///D:\VBA\Book3_Unviewable.xlsm"
   
    Workbooks.Open lk
    wbn = ActiveWorkbook.Name
   
    i = GetVBAProject(Workbooks(wbn))
    MsgBox i
End Sub
Trường hợp hiện thông báo là 1: File excel đang để chế độ vô hiệu hóa macro nên không kiểm tra được.
Trường hợp là 0: File không có macro
Trường hợp là 2,3: có macro. Nếu là 2 thì đang ở chế độ khóa. Nếu là 3 thì macro ở chế độ không khóa.

Tôi đã dựa vào file được cung cấp để làm.
Nó kiểm tra tốt với các file macro không bị khóa, bị khóa thông thường, bị khóa unviewable, tuy nhiên không thể kiểm tra được nếu file để ẩn Module. Nếu bạn không có kiểu file ẩn Module thì code trên, tôi nghĩ là đủ đáp ứng nhu cầu của bạn rồi.
 

USA_Covid19

Thành viên tích cực
Mình cũng góp vui chút vì exe nên không tiện gửi lên
Bạn cần đăng nhập để thấy đa phương tiện
 

Euler

Mod
Thành viên BQT
Bạn chạy thủ tục main, tự sửa đường link file nhé (dòng code số 11).
Tôi sử dụng cách nghĩ của bạn @USA_Covid19 , code bằng VBA.
Code này kiểm tra tất cả các trường hợp, khóa unviewable, khóa thường, ẩn module đều cho kết quả là có macro.
Tôi code hết 4 tiếng, quả thực rất mất thời gian. Hi vọng hữu ích cho bạn.
Mã:
'=================================================
' Thong tin ung ho dien dan
'Ngan hang thuong mai co phan ngoai thuong viet nam vietcombank, so tai khoan: 0011003264055
'Chi nhanh quan Hoan Kiem, Ha Noi
'Chu tai khoan: Pham Minh Hoang
'=================================================
Sub main()
    Dim flg As Boolean 'True: co macro, False: khong co macro
    Dim lk As String
    
    lk = "D:\VBA\test1_khongcomacro.xlsm"
    Call CheckMacro(lk, flg)
    
    If flg = True Then
        MsgBox "co macro"
    Else
        MsgBox "khong co macro"
    End If
End Sub
'https://tuhocvba.net/threads/file-object-completed.409/post-2014
Sub CheckMacro(ByVal lkfile As String, ByRef flg As Boolean)
    Dim FSO As Object
    Dim tenzip  As String
    Dim lk      As Variant
    
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    tenzip = FSO.GetFile(lkfile).Name
    tenzip = tenzip & ".zip"
    lk = FSO.GetFile(lkfile).ParentFolder
    lk = lk & Application.PathSeparator & tenzip
    FSO.GetFile(lkfile).Copy lk
    Set FSO = Nothing
    Call Unzip1(lk, flg)
    Call DeleteFile(lk)
End Sub
'https://stackoverflow.com/questions/35757699/read-txt-from-zip-files
Sub Unzip1(ByVal Fname As Variant, ByRef flg As Boolean)
    Dim FSO As Object
    
    Dim oApp As Object
    Dim FileNameFolder As Variant
    Dim DefPath As String
    Dim strDate As String

    
    If Fname = "" Then
        'Do nothing
    Else
        'Root folder for the new folder.
        'You can also use DefPath = "C:\Users\Ron\test\"
        DefPath = Application.DefaultFilePath
        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If

        'Create the folder name
        strDate = Format(Now, " dd-mm-yy h-mm-ss")
        FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"

        'Make the normal folder in DefPath
        MkDir FileNameFolder

        'Extract the files into the newly created folder
 
        
        Set oApp = CreateObject("Shell.Application")

        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items

      

        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")
        FSO.DeleteFolder Environ("Temp") & "\Temporary Directory*", True
        Call ListFiles(FileNameFolder, flg)
        Call DeleteFolder(FileNameFolder)
    End If
  
End Sub
'http://xl-central.com/list-files-folder-subfolders-fso.html
Sub ListFiles(ByVal sPath As String, ByRef flg As Boolean)

    'Set a reference to Microsoft Scripting Runtime by using
    'Tools > References in the Visual Basic Editor (Alt+F11)
    
    'Declare the variables
    Dim oFSO    As Object
    Dim oFolder As Object
    'Dim sPath As String
    Dim aFiles() As String
    Dim lFileCnt As Long
    Dim sErrMsg As String
    
    'Enable error handling
    On Error GoTo ErrHandler
    
    If flg = True Then Exit Sub
    

    
    'Create an instance of the FileSystemObject
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    
    'Make sure the folder exists
    If Not oFSO.FolderExists(sPath) Then
        sErrMsg = "No such folder exists!"
        GoTo ErrHandler
    End If
    
    'Get the folder
    Set oFolder = oFSO.GetFolder(sPath)
    
    'Get the file names from the specified folder and its subfolders into an array
    Call RecursiveFolder(oFolder, aFiles, lFileCnt, True, flg)
    
    If flg = True Then Exit Sub
    
    'Transfer the list of files from the array to a worksheet in a new workbook
    
    
ExitSub:
    Set oFSO = Nothing
    Set oFolder = Nothing
    Exit Sub
    
    'Error handling
ErrHandler:
    If Len(sErrMsg) > 0 Then
        MsgBox sErrMsg, vbExclamation
        GoTo ExitSub
    Else
        MsgBox "Error " & Err.Number & ":  " & Err.Description
        Resume ExitSub
    End If
    
End Sub

Sub RecursiveFolder(ByRef oFolder As Object, ByRef aFiles() As String, _
                    ByRef lFileCnt As Long, ByRef bIncludeSubFolders As Boolean, ByRef flg As Boolean)

    'Declare the variables
    Dim oFile       As Object
    Dim oSubFolder  As Object
    
    'Loop through each file in the folder
    For Each oFile In oFolder.Files
    
        If UCase(oFile.Name) = UCase("vbaProject.bin") Then
            flg = True
            Exit Sub
        End If
    
    Next oFile
    
    'Loop through files in the subfolders
    If bIncludeSubFolders Then
        For Each oSubFolder In oFolder.SubFolders
            If flg = True Then Exit Sub
            Call RecursiveFolder(oSubFolder, aFiles, lFileCnt, True, flg)
        Next oSubFolder
    End If
    
End Sub
'https://tuhocvba.net/threads/folder-object-completed.421/post-4812
Sub DeleteFolder(ByVal lk As String)
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    ''Xoa thu muc C:\Work
    FSO.GetFolder(lk).Delete
    Set FSO = Nothing
End Sub
'https://tuhocvba.net/threads/file-object-completed.409/post-2658
Sub DeleteFile(ByVal lk As String)
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    ''Xoa file C:\Tmp\Report.xlsx
    FSO.GetFile(lk).Delete
    Set FSO = Nothing
End Sub
 

tuhocvba

Administrator
Thành viên BQT
Hiện thực hóa code của Euler, tôi cung cấp cho bạn chủ topic Tool sau, hi vọng bạn hài lòng. Code hết 3h.
Như vậy tổng thời gian tôi và Euler code hết 7h, gần bằng một ngày đi làm.
Tool:

OUTPUT: Là nơi di chuyển file tới. Yêu cầu không trùng đường dẫn với thư mục INPUT.
INPUT: Là nơi chứa các file macro hoặc không phải macro.
Bạn cần đăng nhập để thấy hình ảnh
 

giaiphapvba

Administrator
Thành viên BQT
Bạn @Binana thân mến. Theo qui định của diễn đàn, bạn có 7 ngày để phản hồi lại là yêu cầu của bạn đã được chúng tôi đáp ứng đúng yêu cầu hay chưa?
Mong bạn hiểu và hợp tác. Nếu không có phản hồi nào, chúng tôi hiểu yêu cầu này đã hoàn thành và trong các yêu cầu hỗ trợ nếu có sau này, chúng tôi sẽ từ chối hỗ trợ.
Bạn cần đăng nhập để thấy hình ảnh
 

Binana

Thành viên mới
Cám ơn tất cả mọi người đã giúp đỡ ạ. Thú thật là em cũng chưa test được. Nhưng nhìn phần kết quả của anh @tuhocvba em thấy có vẻ đúng ấy.
Như vậy tổng thời gian tôi và Euler code hết 7h, gần bằng một ngày đi làm.
Em xin ghi nhận công sức mọi người bỏ ra. Cám ơn mọi người đã nhiệt tình giúp đỡ.
Về phần công sức mọi người bỏ ra. Cũng muốn hỗ trợ 1 phần. Nhưng do đợt dịch này. Bên em đang bị cắt giảm nhân sự. Thành ra cũng lăn tăn việc hỗ trợ hay không hỗ trợ.
Mạn phép cho em xin nợ. Thay vào đó em xin chia sẻ links diễn đàn trên các mạng xã hội để bạn bè và mọi người biết được không ạ?
Lần nữa em xin cám ơn nhiều
 

Euler

Mod
Thành viên BQT
Em xem tivi thì cũng biết rồi đấy. Các anh chị đang làm bên Nhật, được chính phủ hỗ trợ 20 triệu đồng/ người. Cái các anh chị thiếu thì không phải là tiền. Nhưng thời gian có giá trị của nó. Ghi nhận sự phản hồi của bạn, ghi nợ. Khi nào ăn nên làm ra thì nhớ đóng góp ủng hộ diễn đàn nhé.
 
Trạng thái
Không mở trả lời sau này.
Top