Új hozzászólás Aktív témák

• #26653 zhari csendes tag Fferi50 #26648

  Új Válasz 2015-04-23 14:38:24 #26653

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  zhari

  csendes tag

  válasz Fferi50 #26648 üzenetére

  Köszi.

  Ezt találtam még a neten de nem akar működni a szerző és az tulaj bejegyzés kinyerése. Meg tudnátok nézni h mi baja lehet?

  Előre is köszi

  Option Explicit
  
  Public x()
  Public i As Long
  Public objShell, objFolder, objFolderItem
  Public FSO, oFolder, Fil
  Sub MainExtractData()
  Dim NewSht As Worksheet
  Dim MainFolderName As String
  Dim TimeLimit As Long, StartTime As Double
  ReDim x(1 To 65536, 1 To 11)
  Set objShell = CreateObject("Shell.Application")
  TimeLimit = Application.InputBox("Please enter the maximum time that you wish this code to run for in minutes" & vbNewLine & vbNewLine & _
  "Leave this at zero for unlimited runtime", "Time Check box", 0)
  StartTime = Timer
  Application.ScreenUpdating = False
  MainFolderName = BrowseForFolder()
  Set NewSht = ThisWorkbook.Sheets.Add
  x(1, 1) = "Path"
  x(1, 2) = "File Name"
  x(1, 3) = "Last Accessed"
  x(1, 4) = "Last Modified"
  x(1, 5) = "Created"
  x(1, 6) = "Type"
  x(1, 7) = "Size"
  x(1, 8) = "Owner"
  x(1, 9) = "Author"
  x(1, 10) = "Title"
  x(1, 11) = "Comments"
  i = 1
  Set FSO = CreateObject("scripting.FileSystemObject")
  Set oFolder = FSO.GetFolder(MainFolderName)
  'error handling to stop the obscure error that occurs at time when retrieving DateLastAccessed
  On Error Resume Next
  For Each Fil In oFolder.Files
  Set objFolder = objShell.Namespace(oFolder.Path)
  Set objFolderItem = objFolder.ParseName(Fil.Name)
  i = i + 1
  If i Mod 20 = 0 And TimeLimit <> 0 And Timer > (TimeLimit * 60 + StartTime) Then
  GoTo FastExit
  End If
  If i Mod 50 = 0 Then
  Application.StatusBar = "Processing File " & i
  DoEvents
  End If
  x(i, 1) = oFolder.Path
  x(i, 2) = Fil.Name
  x(i, 3) = Fil.DateLastAccessed
  x(i, 4) = Fil.DateLastModified
  x(i, 5) = Fil.DateCreated
  x(i, 6) = Fil.Type
  x(i, 7) = Fil.Size
  x(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
  x(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
  x(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
  x(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
  Next
  'Get subdirectories
  If TimeLimit = 0 Then
  Call RecursiveFolder(oFolder, 0)
  Else
  If Timer < (TimeLimit * 60 + StartTime) Then Call RecursiveFolder(oFolder, TimeLimit * 60 + StartTime)
  End If
  FastExit:
  Range("A:K") = x
  If i < 65535 Then Range(Cells(i + 1, "A"), Cells(65536, "A")).EntireRow.Delete
  Range("A:K").WrapText = False
  Range("A:K").EntireColumn.AutoFit
  Range("1:1").Font.Bold = True
  Rows("2:2").Select
  ActiveWindow.FreezePanes = True
  Range("a1").Activate
  Set FSO = Nothing
  Set objShell = Nothing
  Set oFolder = Nothing
  Set objFolder = Nothing
  Set objFolderItem = Nothing
  Set Fil = Nothing
  Application.StatusBar = ""
  Application.ScreenUpdating = True
  End Sub
  Sub RecursiveFolder(xFolder, TimeTest As Long)
  Dim SubFld
  For Each SubFld In xFolder.Subfolders
  Set oFolder = FSO.GetFolder(SubFld)
  Set objFolder = objShell.Namespace(SubFld.Path)
  For Each Fil In SubFld.Files
  Set objFolder = objShell.Namespace(oFolder.Path)
  'Problem with objFolder at times
  If Not objFolder Is Nothing Then
  Set objFolderItem = objFolder.ParseName(Fil.Name)
  i = i + 1
  If i Mod 20 = 0 And TimeTest <> 0 And Timer > TimeTest Then
  Exit Sub
  End If
  If i Mod 50 = 0 Then
  Application.StatusBar = "Processing File " & i
  DoEvents
  End If
  x(i, 1) = SubFld.Path
  x(i, 2) = Fil.Name
  x(i, 3) = Fil.DateLastAccessed
  x(i, 4) = Fil.DateLastModified
  x(i, 5) = Fil.DateCreated
  x(i, 6) = Fil.Type
  x(i, 7) = Fil.Size
  x(i, 8) = objFolder.GetDetailsOf(objFolderItem, 8)
  x(i, 9) = objFolder.GetDetailsOf(objFolderItem, 9)
  x(i, 10) = objFolder.GetDetailsOf(objFolderItem, 10)
  x(i, 11) = objFolder.GetDetailsOf(objFolderItem, 14)
  Debug.Print x(i, 1), x(i, 2), x(i, 11)
  Else
  Debug.Print Fil.Path & " " & Fil.Name
  End If
  Next
  Call RecursiveFolder(SubFld, TimeTest)
  Next
  End Sub
  Function BrowseForFolder(Optional OpenAt As Variant) As Variant
  'Function purpose: To Browser for a user selected folder.
  'If the "OpenAt" path is provided, open the browser at that directory
  'NOTE: If invalid, it will open at the Desktop level
  Dim ShellApp As Object
  'Create a file browser window at the default folder
  Set ShellApp = CreateObject("Shell.Application"). _
  BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
  'Set the folder to that selected. (On error in case cancelled)
  On Error Resume Next
  BrowseForFolder = ShellApp.self.Path
  On Error GoTo 0
  'Destroy the Shell Application
  Set ShellApp = Nothing
  'Check for invalid or non-entries and send to the Invalid error
  'handler if found
  'Valid selections can begin L: (where L is a letter) or
  '\\ (as in \\servername\sharename. All others are invalid
  Select Case Mid(BrowseForFolder, 2, 1)
  Case Is = ":"
  If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
  Case Is = "\"
  If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
  Case Else
  GoTo Invalid
  End Select
  Exit Function
  Invalid:
  'If it was determined that the selection was invalid, set to False
  BrowseForFolder = False
  End Function

Új hozzászólás Aktív témák