AW: dateinamen + daten v. explorer -> xls
22.11.2003 17:23:10
Reinhard
Hi Martin,
probier mal mein Makro.
Du musst natürlich das Diskettenlaufwerkslämpchen beachten beim Diskettenwechsel, da ich nichts fand was Diskettenwechsel nach VBA meldet und ich halt das Disk-LW alle x Sekunden überprüfen muss.
Abbruch des Endlosmakros durch Strg+Pause.
Makro sucht alle Docs aus Disketten raus, bei anderen Endungen musst du es anpassen.
Grundsätzlich würde ich alle Dateien samt VolumeLabel aller in Betracht kommenden Disketten komplett auf Festplatte speichern, ggfs. dort lassen oder auf CD, dann aufgrund dieser Speichermedien solche Listen erstellen, denn wenn im März jemand 'ne Liste aller *.xyz-Dateien auf den Disketten haben will... :-)
Gruß
Reinhard
Option Explicit
Private Declare
Sub Sleep Lib "kernel32" (ByVal dwMS As Long)
Dim BildDisk As String 'Bild: Bitte Diskette einlegen
Dim BildWork As String 'Bild: Excel arbeitet
Dim BildChange As String 'Bild: Bitte Diskette wechseln
Sub Doc_aus_A_Lesen()
Dim WS As Worksheet
Dim NächsteZeile As Long
Dim n As Integer
Dim Datei As String
Dim fs As Object
Set WS = Worksheets("Tabelle3")
WS.Activate
Call Bilder
On Error Resume Next 'da Fehler wenn Diskette nicht eingelegt
Schleife: ' Abbruch des Endlosmakros mit Strg+Pause
WS.Pictures(BildDisk).Visible = True
While Dir("a:\*.*") = "" ' keine Diskette eingelegt
Sleep 5000 ' Millisekunden
Wend
WS.Pictures(BildDisk).Visible = False
WS.Pictures(BildChange).Visible = False
WS.Pictures(BildWork).Visible = True
NächsteZeile = WS.Cells(65536, 1).End(xlUp).Row 'letzte beschriebene Zeile
With Application.FileSearch
.NewSearch
.LookIn = "a:\"
.SearchSubFolders = True
.FileType = msoFileTypeWordDocuments
If .Execute() > 0 Then
For n = 1 To .FoundFiles.Count
Datei = .FoundFiles(n) ' Foundfiles ist mit Pfad, Datei ohne Pfad
While InStr(Datei, "\")
Datei = Right(Datei, Len(Datei) - InStr(Datei, "\")) 'Pfad entfernen
Wend
WS.Cells(NächsteZeile + n, 1) = Datei 'Name ohne Pfad
WS.Cells(NächsteZeile + n, 2) = FileDateTime(.FoundFiles(n)) 'auf Datum reduzieren
WS.Cells(NächsteZeile + n, 3) = .FoundFiles(n) 'Name mit Pfad
Next n
End If
End With
WS.Pictures(BildWork).Visible = False
WS.Pictures(BildChange).Visible = True
Set fs = CreateObject("Scripting.FileSystemObject")
While fs.fileexists(WS.Cells(NächsteZeile + n - 1, 3)) ' alte Diskette noch drin
Sleep 5000
Wend
Set fs = Nothing
WS.Pictures(BildChange).Visible = False
GoTo Schleife
End Sub
Sub Bilder()
Application.ScreenUpdating = False
ActiveSheet.Pictures.Insert("http://www.axus.com.tw/br86003.gif").Select
BildDisk = Selection.Name
ActiveSheet.Pictures(BildDisk).Top = 0
ActiveSheet.Pictures(BildDisk).Left = ActiveSheet.Range("D1").Left
ActiveSheet.Pictures(BildDisk).Visible = False
ActiveSheet.Pictures.Insert("http://www.troxlerlabs.com/images/working.gif").Select
BildWork = Selection.Name
ActiveSheet.Pictures(BildWork).Top = 0
ActiveSheet.Pictures(BildWork).Left = ActiveSheet.Range("D1").Left
ActiveSheet.Pictures(BildWork).Visible = False
ActiveSheet.Pictures.Insert("http://www.ultimativ.ch/cartoons/humor3/diskette_einlegen.jpg").Select
BildChange = Selection.Name
ActiveSheet.Pictures(BildChange).Top = 0
ActiveSheet.Pictures(BildChange).Left = ActiveSheet.Range("D1").Left
ActiveSheet.Pictures(BildChange).Visible = False
Application.CutCopyMode = False
ActiveSheet.Range("a1").Select
Application.ScreenUpdating = True
End Sub
Sub loesch() 'beim testen Bilder löschen
For Each bb In ActiveSheet.Pictures()
bb.Delete
Next bb
End Sub