'=================================================
' 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