Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
364to368
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
364to368
364to368
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Programm das CD-Inhalt-Liste schreibt?

Programm das CD-Inhalt-Liste schreibt?
19.01.2004 22:31:46
Johannes Haseitl
Hallo,
ich suche eine Möglichkeit den Inhalt meiner CD's (Daten-CDs) in einer Excelliste zu speichern. Ich würd dazu gerne alle Datei-/und Ordnernamen aller daraufbefindlichen Dateien, bzw. deren Pfade, in einer Liste speichern wollen(ein Tabellenblatt für jede CD).
Würd auch gern gleich das Tabellenblatt mit Hilfe eines Eingabefensters benennen wollen.
Ich hoff ihr könnt mir da weiterhelfen.
Gruß Johannes
(natürlich muss das mit dem Eingabefenster nich unbedingt sein)

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Programm das CD-Inhalt-Liste schreibt?
19.01.2004 23:36:58
K.Rola
Hallo,
willst du einfach alle Ordner untereinander oder mit Struktur so ähnlich
wie im Explorer?
Gruß K.Rola
Es genügt mir wenn es einfach untereinander steht
20.01.2004 00:10:02
Haseitl Johannes
Hi K.Rola
Es genügt mir wenn es einfach untereinander steht, es sollen aber auch die dateinamen der einzelnen dateien angezeigt werden.
Gruß johannes
Bsp: Wie ich es mir vorstellen könnte:
datei.bmp
ordner1\
ordner1\datei1.zip
ordner1\datei2.zip
ordner1\uordner1\
ordner2\
ordner2\datei.xls
AW: Es genügt mir wenn es einfach untereinander steht
20.01.2004 01:19:23
K.Rola
Hallo,
kopier den Code in ein Standardmodul. Wenn du das makro ausführst, erklärt
sich das von selbst, du kannst zuerst ein Verzeichnis auswählen:
Option Explicit
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BInfo) As Long
Private Declare Function CoTaskMemFree Lib "ole32" (ByVal hMem As Long) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpStr1 As String, ByVal lpStr2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pList As Long, ByVal lpBuffer As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassname As String, ByVal lpWindowName As String) As Long
Private Type BInfo
hwnd As Long
Root As Long
DisplayName As Long
Title As Long
Flags As Long
FName As Long
lParam As Long
Image As Long
End Type

Private Function GetFolder() As String
Dim xl As BInfo, IDList As Long, RetVal As Long, FolderName As String
With xl
.hwnd = FindWindow("xlmain", vbNullString)
.Title = lstrcat("Verzeichnis wählen...", "")
.Flags = 1
End With
IDList = SHBrowseForFolder(xl)
If IDList <> 0 Then
FolderName = Space(256)
RetVal = SHGetPathFromIDList(IDList, FolderName)
CoTaskMemFree (IDList)
FolderName = Trim$(FolderName)
FolderName = Left(FolderName, Len(FolderName) - 1)
End If
GetFolder = FolderName
End Function

Sub Dateien_suchen()
Dim Medium As String, Index As Long, objFSO As Object, objFolder As Object
Dim Zeile As Long, Spalte As Integer
Medium = GetFolder
If Medium <> "" Then
Application.ScreenUpdating = False
On Error Resume Next
Cells.Clear
Cells(1, 1) = "Pfad/Dateiname"
Cells(1, 2) = "KB"
Zeile = 1: Spalte = 1
Set objFSO = CreateObject("Scripting.FileSystemObject")
With Application.FileSearch
.LookIn = Medium
.SearchSubFolders = True
If .Execute > 0 Then
For Index = 1 To .FoundFiles.Count
Set objFolder = objFSO.GetFile(.FoundFiles(Index))
If objFolder.Size > 0 Then
Zeile = Zeile + 1
If Zeile > 65500 Then Spalte = Spalte + 2
Cells(Zeile, Spalte) = objFolder.Path
Cells(Zeile, Spalte + 1) = objFolder.Size / 1024
End If
Next
End If
End With
For Spalte = 2 To 20
Columns(Spalte).NumberFormat = "#,##0.00"
Next
Columns.AutoFit
Rows(1).Font.Bold = True
Application.ScreenUpdating = True
End If
End Sub

Gruß K.Rola
Anzeige
Funktioniert irgendwie net
20.01.2004 14:31:53
Haseitl Johannes
Danke K.Rola,
es funktioniert aber irgendwie nich richtig.
Es wird immer nur der Kopr: "Pfad/Dateiname" und "KB" angezeigt
siehe: https://www.herber.de/bbs/user/3060.xls
AW: Versuch das...
20.01.2004 19:20:00
K.Rola
Hallo,
habs jetzt nicht nochmal probiert und auch keine Zeit zur Fehlersuche
aber dann nimm dies. Du musst nur den Laufwerksbuchstaben eingeben:
Option Explicit
Option Base 1

Sub VerzeichnisseAuslesen()
Const MINIMUM As Double = 0
Dim objFS As Object, Groesse As Double, z As Long
Dim strLookIn As String, FName As String, strLW As String
Dim arrF() As String, F As Long, bolFound As Boolean
Columns("A:B").Clear
On Error GoTo ende
strLW = Application.InputBox("Bitte Laufwerk eingeben...", Default:="C", Type:=2)
If VarType(strLW) = 11 Then Exit Sub
If strLW = "" Then Exit Sub
strLookIn = UCase(strLW) & ":\"
If Dir(strLookIn, vbVolume) = "" Then
MsgBox "Das Verzeichnis " & strLookIn & " ist nicht vorhanden!        ", 64, "weise hin..."
Exit Sub
End If
FName = "*.*"
Set objFS = Application.FileSearch
With objFS
.LookIn = strLookIn
.FileName = FName
.SearchSubFolders = True
If .Execute > 0 Then
For F = 1 To .FoundFiles.Count
ReDim Preserve arrF(F)
arrF(F) = .FoundFiles(F)
Next
For F = 1 To UBound(arrF)
Groesse = FileLen(arrF(F)) / 1024
If Groesse > MINIMUM Then
bolFound = True
z = z + 1
If z > 65500 Then Exit Sub
Cells(z, 1) = arrF(F)
Cells(z, 2) = Groesse
End If
Next
Else
MsgBox "Keine Dateien gefunden!          ", 64, "weise hin..."
End If
End With
Columns(2).NumberFormat = "#,##0.00 ""KB"""
Columns(2).AutoFit
Set objFS = Nothing
If Not bolFound Then
MsgBox "Keine Dateien größer " & MINIMUM & " KB gefunden!          ", 64, "weise hin..."
End If
ende:
End Sub

Gruß K.Rola
Anzeige
OT: Du hast Post oT
20.01.2004 22:35:56
Boris
DANKE, hat funktioniert
21.01.2004 10:16:17
Haseitl Johannes
Recht herzlichen Dank, K.Rola
Funktioniert!

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige