파일목록생성샘플

Option Explicit

Dim hItem            As Long

Dim hFile            As Long

Dim WFD              As WIN32_FIND_DATA

Dim UseFileSpec      As Boolean

Dim CreationTime     As Double

Dim lstIdx           As Integer

Dim wFile            As String

Dim uFile            As String

Const vbKeyDot = 46

Const ExcelLove = "엑사모 - http://www.excellove.com"

Private Sub cmdClose_Click()

   

With Application

   .DisplayAlerts = True

   .ScreenUpdating = True

   .Cursor = xlDefault

End With

Unload Me

End Sub

Private Sub cmdFindNow_Click()

Dim i          As Integer

Dim MyDrive    As String

Dim wbNew      As Workbook

Dim shtTarget  As Worksheet

Application.Cursor = xlWait

LstFound.Clear

lstIdx = -1

wFile = ""

uFile = ""

CreationTime = 0

With lstFolder

   For i = 0 To .ListCount - 1

      MyDrive = Left(.List(i), 2)

      If GetDrvInfo(MyDrive) Then

         DoEvents

         Call cFile_Find(.List(i))

      Else

         Application.Cursor = xlDefault

         MsgBox "드라이브 " & MyDrive & "에서 읽어오는중 오류가 발생했습니다." & vbCr & vbCr & _

                "디스크가 드라이브에 삽입되지 않았거나 장치가 준비되지 않았습니다.", vbCritical, ExcelLove

         Exit Sub

      End If

   Next i

End With

Application.Cursor = xlDefault

With LstFound

   If .ListCount > 0 Then

      Frame2.Enabled = True

      LstFound.Enabled = True

      LstFound.ListIndex = lstIdx

      If chkExportToSheet.Value Then

         Set wbNew = Workbooks.Add

         Set shtTarget = wbNew.ActiveSheet

         With shtTarget

            .Range("A1").Value = "파일 경로 및 파일명"

            .Range("B1").Value = "경로"

            .Range("C1").Value = "파일명"

            .Range("D1").Value = "만든 날짜"

            .Range("E1").Value = "크기"

            .Range("A2:E" & LstFound.ListCount + 1).Value = LstFound.List

            .Range("A1").CurrentRegion.Resize(, 1).Offset(, 3).NumberFormat = "yyyy-mm-dd hh:mm:ss"

            .Columns("A:E").AutoFit

         End With

         MsgBox "총 " & LstFound.ListCount & "개의 파일이 검색되었습니다.", vbInformation, ExcelLove

      End If

   Else

      MsgBox "선택한 폴더에서 파일을 발견할 수 없습니다.", vbExclamation, ExcelLove

   End If

End With

End Sub

Private Sub cmdFolderAdd_Click()

Dim bi      As BROWSEINFO

Dim pidl    As Long

Dim Path    As String

Dim pos     As Integer

Dim i       As Integer

Dim Added   As Boolean

Dim ObjFld  As String

bi.hOwner = GetActiveWindow()

bi.pidlRoot = 0&

bi.lpszTitle = "폴더를 선택하십시오."

bi.ulFlags = BIF_RETURNONLYFSDIRS

pidl = SHBrowseForFolder(bi)

Path = Space$(512)

If SHGetPathFromIDList(ByVal pidl&, ByVal Path) Then

   pos = InStr(Path, Chr$(0))

   If UCase(Left(Path, 1)) >= "A" And UCase(Left(Path, 1)) <= "Z" Then

      Added = False

      ObjFld = Left(Path, pos - 1)

      With lstFolder

         If ChkIncludeSubFolder And .ListCount > 0 Then

            With lstFolder

               For i = .ListCount - 1 To 0 Step -1

                  If InStr(.List(i), ObjFld) = 1 Then .RemoveItem (i)

               Next

            End With

         End If

         For i = 0 To .ListCount - 1

            If .List(i) = ObjFld Then

               MsgBox "폴더 : " & ObjFld & vbCr & vbCr & _

                  "이 폴더는 이미 검사할 폴더에 추가되어 있습니다.", vbInformation, ExcelLove

               Added = True

               Exit For

            ElseIf InStr(ObjFld, .List(i)) = 1 And ChkIncludeSubFolder Then

               MsgBox "폴더 " & Left(Path, pos - 1) & vbCr & vbCr & _

                  "이 폴더는 이미 검사할 상위 폴더에 추가되어 있습니다.", vbInformation, ExcelLove

               Added = True

               Exit For

            End If

         Next

         If Not Added Then .AddItem ObjFld

         Call txtExt_Change

      End With

   Else

      MsgBox "현재 선택한 폴더(경로)는 지원되지 않습니다.", vbExclamation, ExcelLove

   End If

End If

End Sub

Private Sub cmdFolderRemove_Click()

With lstFolder

   .RemoveItem (.ListIndex)

End With

lstFolder_Click

End Sub

Private Sub cmdOk_Click()

MsgBox "이곳에 필요한 코딩을 합니다.", vbInformation, ExcelLove

End Sub

Private Sub Frame1_Click()

End Sub

'

' 찾을 파일 폴더 목록에서 목록을 클릭했을때 삭제단추/찾기단추등 사용가능토록 설정

'

Private Sub lstFolder_Click()

Dim i As Integer

Dim F As Boolean

F = False

With lstFolder

   If .ListCount > 0 Then

      For i = 0 To .ListCount - 1

         If .Selected(i) Then

            F = True: Exit For

         End If

      Next

   End If

   cmdFolderRemove.Enabled = F

   Label1.Enabled = .ListCount > 0

   cmdFindNow.Enabled = .ListCount > 0

End With

End Sub

'

' 파일찾기 시작

'

Private Sub cFile_Find(fDrv As String)

On Error Resume Next

If Right(fDrv, 1) <> Application.PathSeparator Then fDrv = fDrv & Application.PathSeparator

UseFileSpec = True

Call SearchDirs(fDrv)

UseFileSpec = False

End Sub

'

' 폴더에서 지정된 파일확장자를 모두 찾음

'

Private Sub SearchDirs(curPath As String)

Dim dirs       As Integer

Dim i          As Integer

Dim dirbuf()

Dim pos        As Integer

Dim FileSpec   As String

Dim strTemp    As String

DoEvents

hItem = FindFirstFile(curPath & "*.*", WFD)

If hItem <> INVALID_HANDLE_VALUE Then

   Do

      If (WFD.dwFileAttributes And vbDirectory) Then

         If Asc(WFD.cFileName) <> vbKeyDot Then

            If (dirs Mod 10) = 0 Then ReDim Preserve dirbuf(dirs + 10)

            dirs = dirs + 1

            dirbuf(dirs) = Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)

         End If

      End If

   Loop While FindNextFile(hItem, WFD)

   Call FindClose(hItem)

End If

'

' 입력된 파일명과 확장자를 기준으로 파일을 찾음

'

If UseFileSpec Then

   If Right(txtExt.Text, 1) = ";" Then

      FileSpec = txtExt.Text

   Else

      FileSpec = txtExt.Text & ";"

   End If

   Do

      pos = InStr(FileSpec, ";")

      If pos >= 1 Then

         strTemp = Left(FileSpec, pos - 1)

         Call SearchFileSpec(curPath, strTemp)

      End If

      FileSpec = Mid(FileSpec, pos + 1)

   Loop While FileSpec <> ""

End If

If ChkIncludeSubFolder Then

   For i = 1 To dirs

      SearchDirs curPath & dirbuf(i) & Application.PathSeparator

   Next i

End If

End Sub

Sub SearchFileSpec(curPath As String, FileExt As String)

Dim st         As SYSTEMTIME

Dim ftLocal    As FILETIME

Dim x          As Double

Dim strFName   As String

hFile = FindFirstFile(curPath & FileExt, WFD)

If hFile <> INVALID_HANDLE_VALUE Then

   Do

      Call FileTimeToLocalFileTime(WFD.ftCreationTime, ftLocal)

      Call FileTimeToSystemTime(ftLocal, st)

      Call SystemTimeToVariantTime(st, x)

      strFName = Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)

      '

      ' 파일명이 폴더인 경우 제외

      '

      If strFName = "." Or strFName = ".." Then

      Else

         wFile = curPath & Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)

         LstFound.AddItem wFile

         LstFound.List(LstFound.ListCount - 1, 1) = curPath

         LstFound.List(LstFound.ListCount - 1, 2) = Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)

         LstFound.List(LstFound.ListCount - 1, 3) = Format(x, "yyyy-mm-dd hh:mm:ss")

         LstFound.List(LstFound.ListCount - 1, 4) = Format(WFD.nFileSizeHigh * 256 + WFD.nFileSizeLow, "#,##0")

         Frame2.Caption = "찾은파일(" & LstFound.ListCount & "개)"

         If x > CreationTime Then

            CreationTime = x

            uFile = wFile

            lstIdx = LstFound.ListCount - 1

         End If

      End If

   Loop While FindNextFile(hFile, WFD)

   Call FindClose(hFile)

End If

End Sub

Private Sub LstFound_Click()

cmdOK.Enabled = True

End Sub

Private Sub txtExt_Change()

With lstFolder

   Label1.Enabled = .ListCount > 0 And Len(txtExt.Text) > 0

   lstFolder.Enabled = .ListCount > 0 And Len(txtExt.Text) > 0

   cmdFindNow.Enabled = .ListCount > 0 And Len(txtExt.Text) > 0

End With

End Sub

Private Sub UserForm_Click()

End Sub

'======================================================================

Option Explicit

' 파일의 날짜를 읽어오기 위해 사용할 상수들

Public Const MaxLFNPath = 260

Public Const INVALID_HANDLE_VALUE = -1

' 브라우저를 보여주기에 사용할 상수들

Public Const BIF_RETURNONLYFSDIRS = &H1

Public Const BIF_DONTGOBELOWDOMAIN = &H2

Public Const BIF_STATUSTEXT = &H4

Public Const BIF_RETURNFSANCESTORS = &H8

Public Const BIF_BROWSEFORCOMPUTER = &H1000

Public Const BIF_BROWSEFORPRINTER = &H2000

Public Const BIF_BROWSEINCLUDEFILES = &H4000

Public Const BIF_EDITBOX = &H10

Public Const BIF_VALIDATE = &H20

Public Const BIF_NEWDIALOGSTYLE = &H40

Public Const BIF_BROWSEINCLUDEURLS = &H80

Public Const BIF_SHAREABLE = &H8000

Public Type SYSTEMTIME

  wYear              As Integer

  wMonth             As Integer

  wDayOfWeek         As Integer

  wDay               As Integer

  wHour              As Integer

  wMinute            As Integer

  wSecond            As Integer

  wMilliseconds      As Long

End Type

Public Type FILETIME

   dwLowDateTime     As Long

   dwHighDateTime    As Long

End Type

Public Type WIN32_FIND_DATA

   dwFileAttributes  As Long

   ftCreationTime    As FILETIME

   ftLastAccessTime  As FILETIME

   ftLastWriteTime   As FILETIME

   nFileSizeHigh     As Long

   nFileSizeLow      As Long

   dwReserved0       As Long

   dwReserved1       As Long

   cFileName         As String * MaxLFNPath

   cShortFileName    As String * 14

End Type

Public Type BROWSEINFO

   hOwner            As Long

   pidlRoot          As Long

   pszDisplayName    As String

   lpszTitle         As String

   ulFlags           As Long

   lpfn              As Long

   lParam            As Long

   iImage            As Long

End Type

Declare Function GetActiveWindow Lib "user32.dll" () As Long

' 브라우저를 보여주기 위한 함수들

Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

' 파일을 찾는데 사용할 함수들

Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long

Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long

Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

' 파일의 날짜를 읽어오기 위해 사용할 함수들

Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long

Declare Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long

Declare Function SystemTimeToFileTime Lib "kernel32" (lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) As Long

Declare Function SystemTimeToVariantTime Lib "oleaut32" (psystime As SYSTEMTIME, pvtime As Double) As Long

' 디스크 드라이브의 정보를 읽어오기 위한 함수

Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long) As Long

'

' 드라이브의 정보를 읽어온다

' 해당 드라이브에 오류없이 정상적으로 읽히면 rc 에는 1이 온다

'

Public Function GetDrvInfo(gDrive As String) As Boolean

   Dim rc                     As Long

   Dim nSerial                As Long

   Dim Vol                    As String

   Dim fSystem                As String

   Dim nMaxFileName           As Long

   Dim nFileSystemFlags       As Long

   Vol = Space(255)

   fSystem = Space(255)

   If Right(gDrive, 1) <> Application.PathSeparator Then gDrive = gDrive & Application.PathSeparator

   rc = GetVolumeInformation(gDrive, Vol, Len(Vol), nSerial, nMaxFileName, nFileSystemFlags, fSystem, Len(fSystem))

   GetDrvInfo = (rc = 1)

End Function