vbs批量读取文件夹的文件

admin

Get_file()
function Get_file()
dim a
a=InputBox("Please enter the full path name of the folder","Warm prompt!")
if a = vbEmpty  then
else
if a = "" then
msgbox "Cannot be empty, please re-enter!"
else
dim b
b=Split(a,",")
dim fso,f,h,j,m,m1,m2
set fso= CreateObject("scripting.FileSystemObject")
if fso.FolderExists(b(0)) then
   set f=fso.GetFolder(b(0))
   select case UBound(b)
   case 1
   h = b(1)
   m = Instr(h, "-")
   m1 = Left(h, m)
   m2 = Right(h, len(h)-m)
   case 2
   h = b(1)
   m = Instr(h, "-")
   m1 = Left(h,m)
   m2 = Right(h, len(h)-m)
   j = b(2)
end select

dim Arr1()
dim Arr2()
dim index
index = 0
For Each objfile in f.Files
   dim s1,s2,s3,s4,s5,s6,s7,s8,s9,s10,c1,c2,c3,c4,c5
    s1 = objfile.name
    s2 = InStrRev(s1, ".")
    if(s2 = 0) Then                    
        s3 = s1
    else
        s3 = Left(s1, s2 - 1)
    end if
   select case len(m2)
    case 1
       c5 = "0000" & m2
    case 2
       c5 = "000" & m2
    case 3
       c5 = "00" & m2
    case 4
       c5 = "0" & m2
    case 5
       c5 = m2
   end select
   s4 = m1 & c5 & "_" & s3 & " " & j
   s5 = f & "\" & s4

   s6 = Instr(s3, "(")
   if(s6 = 0) Then                    
        c1 = s3
    else
        c1 = Left(s3, s6 - 1)
    end if
     
    s7 = InStrRev(s3, "-")
    if(s7 = 0) Then                    
        c3 = s3
     else
        c2 = Right(s3, len(s3)-s7)
        s8 = Instr(c2, "(")
           if (s8 = 0) Then  
              c3 = c2
           else
             c3 = Left(c2,s8-1)
           end if
    end if
    ReDim Preserve Arr1(index)
    Arr1(index)=c1
    ReDim Preserve Arr2(index)
    Arr2(index)=c3
    index = index + 1
    s9 = f & "\" & s1
    s10 = s5 & "\" & s1
    if fso.FolderExists(s5) then
     if fso.fileExists(s10) then
      else
      fso.MoveFile s9,s10
      end if
   else
      fso.CreateFolder(s5)
      fso.MoveFile s9,s10
   end if
  m2 = m2 + 1
next
on error resume next
dim u_ss
u_ss=ubound(Arr1)
if err then
else
dim FileName,ExcelApp,ExcelBook,FolderName,CurrentDate,ExcelSheet,openexcel,rowcount,openSheet
CurrentDate = "New_Excel_" & year(Now)
FolderName = f & "\" & CurrentDate
if fso.FolderExists(FolderName) then  
      FileName = FolderName & "\" & CurrentDate & ".xlsx"
   else
      fso.CreateFolder(FolderName)
      FileName = FolderName & "\" & CurrentDate & ".xlsx"
   end if
if fso.fileExists(FileName) then
   else
    set ExcelApp = CreateObject("Excel.Application")
     set ExcelBook = ExcelApp.Workbooks.Add
     set ExcelSheet = ExcelBook.ActiveSheet
      ExcelSheet.Columns("A:B").AutoFit()
      dim ar1,ar2
      ar1=1
      ar2=1
      for each r1 in Arr1
          ExcelSheet.Range("A" & ar1)=r1
          ar1=ar1+1
      next
      for each r2 in Arr2
          ExcelSheet.Range("B" & ar2)=r2
          ar2=ar2+1
      next
      ExcelBook.SaveAs(FileName)
      ExcelBook.Close
      Set ExcelBook = Nothing
      set ExcelSheet = Nothing
      ExcelApp.Quit
      Set ExcelApp = Nothing
   end if
end if
else
    MsgBox "The entered folder does not exist."
end if
set fso = Nothing
end If
end If
end function