Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1500to1504
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
Inhaltsverzeichnis

ChDrive netzwerklaufwerke auslesen

ChDrive netzwerklaufwerke auslesen
12.07.2016 10:25:00
baschti007
Hallo Wie kann ich ChDrive ab ändern damit ich auch Netzwerkpfade (unter Ordner) auslesen kann ?

Public Function ASCIItoANSI(ByVal Text As String) As String
Call OemToCharA(Text, Text)
ASCIItoANSI = Text
End Function
Sub pdf_auflisten()
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
.Title = "Ordnerauswahl"
.ButtonName = "Auswahl..."
.InitialView = msoFileDialogViewList
If .Show = -1 Then
pfad = .SelectedItems(1)
If Right(pfad, 1)  "\" Then pfad = pfad & "\"
Else
pfad = ""
End If
End With
If pfad = "" Then MsgBox ("Kein Ordner gewählt!"): Exit Sub Else MsgBox pfad
'------------ Ordner und Unterordner durchsuchen nach z.B PDF Und .xlsm
ActiveSheet.Columns("A:B").ClearContents
Dim objShell As Object, objExec As Object
Dim vntRet As Variant, strTMP As String
Dim Ws2 As Worksheet
Set Ws2 = Tabelle2
Set objShell = CreateObject("WScript.Shell")
ChDrive Left(pfad, 1)
ChDir pfad
Set objExec = objShell.Exec("cmd /c dir /s /b *.pdf *.xlsm")
strTMP = ASCIItoANSI(objExec.StdOut.ReadAll)
vntRet = Split(strTMP, vbCrLf)
'------------ Ordner und Unterordner durchsuchen nach z.B PDF
If UBound(vntRet) > 0 Then
zeile = 2
Ws2.Range("A2").Resize(UBound(vntRet), 1) = Application.Transpose(vntRet)
For Z = 1 To UBound(vntRet)
With Ws2
.Hyperlinks.Add Anchor:=.Range("A" & zeile), Address:=.Range("A" & zeile), ScreenTip:=.Range( _
_
"A" & zeile).Value, TextToDisplay:=.Range("A" & zeile).Value
End With
Ws2.Cells(zeile, 2) = Mid(Ws2.Cells(zeile, 1), InStrRev(Ws2.Cells(zeile, 1), "\") + 1)
zeile = zeile + 1
Next
End If
Set objShell = Nothing
End Sub

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
chdrive nicht nötig
12.07.2016 23:13:54
Michael
Hi Baschti,
das Wechseln von Laufwerk & Verzeichnis braucht es nicht, wenn Du den Pfad direkt in die "Kommandozeile" steckst.
Was Du hier treibst, kannst Du testhalber mal in der "Dos-Box" machen, und Du wirst sehen, daß das SO nicht geht, denn:
C:\temp>dir                *** Das ist da ***
09.07.2016  12:00         1.030.782 Bild1.bmp
12.07.2016  22:44                 3 bla.xlsm
02.06.2016  23:48            11.118 HerberTestGIF.gif
02.06.2016  23:56            36.297 HerberTestJPG.jpg
12.07.2016  22:43                 5 test.xlsx
12.07.2016  22:43                 3 test1.xls
12.07.2016  22:43                 5 test2.xls
07.07.2016  17:55             8.527 TestGIF.gif
897.284.559.261.696 Bytes frei
C:\temp>dir *.bmp               *** Findet die eine Datei, ok ***
09.07.2016  12:00         1.030.782 Bild1.bmp
897.284.559.261.696 Bytes frei
C:\temp>dir *.bmp *.gif         *** Findet NUR die zuletzt genannten "*.gif" ***
02.06.2016  23:48            11.118 HerberTestGIF.gif
07.07.2016  17:55             8.527 TestGIF.gif
897.284.559.261.696 Bytes frei
C:\temp>dir *.xls *.xlsx        *** Findet AUCH bla.xlsm, obwohl NICHT angegeben. ***
12.07.2016  22:44                 3 bla.xlsm
12.07.2016  22:43                 3 test1.xls
12.07.2016  22:43                 5 test2.xls
12.07.2016  22:43                 5 test.xlsx
12.07.2016  22:43                 5 test.xlsx
897.284.559.261.696 Bytes frei
C:\temp>blink, blink
Du kannst in der Kommandozeile nicht nach mehreren Endungen gleichzeitig suchen.
Also etwa so: objShell.Exec("cmd /c dir " & pfad & "*.pdf /s /b")
Falls der Pfad Leerzeichen enthält, muß er noch in "" gesetzt werden, also
Sub t()
Dim pfad$
pfad = "C:\Pfad mit Leerzeichen\"
Debug.Print "cmd /c dir """ & pfad & "*.pdf"" /s /b"
' Ausgabe: cmd /c dir "C:\Pfad mit Leerzeichen\*.pdf" /s /b
End Sub
bzw.
objShell.Exec("cmd /c dir """ & pfad & "*.pdf"" /s /b")

Schöne Grüße,
Michael

Anzeige
AW: chdrive nicht nötig
13.07.2016 07:17:57
baschti007
Halli Hallo Michael =)
Ich habe es getestet das es doch funktioniert mehrere Endungen zu finden hier mit

objExec = objShell.Exec("cmd /c dir /s /b *.pdf *.xlsm *.gif")
pre>
aber du sagtest das er immer nur das letzte findet ist bei mir nicht der fall es werden alle  _
Endungen aufgelistet.Musst du mal testen.
Das mit dem Pfad hatte ich auch schon probiert gehabt das ging gut auch mit Netzwerkpfaden aber  _
leider keine mehrfachen Endungen.
Gruß Basti

AW: chdrive nicht nötig
13.07.2016 07:18:58
baschti007
ups das meinte ich =D

Set objExec = objShell.Exec("cmd /c dir /s /b *.pdf *.xlsm *.gif")

Anzeige
AW: chdrive nicht nötig
13.07.2016 11:06:03
Michael
Hi,
das stimmt - sehr seltsam...
@Rudi: danke für die Variante, ich hab sie gleich mal in mein Archiv übernommen.
Schöne Grüße,
Michael

AW: ChDrive netzwerklaufwerke auslesen
13.07.2016 09:51:17
Rudi
Hallo,
ich mache das in der Art:
Option Explicit
Dim FSO As Object
Sub DateiListe()
Dim oFolder As Object, oDictF As Object
Dim strFolder As String, arrHeader, wksListe As Worksheet
Dim lngColumns As Long
Dim arrItems, arrOut, i As Integer, j As Integer
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Ordner wählen"
.AllowMultiSelect = False
If .Show = -1 Then
strFolder = .SelectedItems(1)
End If
End With
If strFolder = "" Then Exit Sub
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = FSO.GetFolder(strFolder)
Set oDictF = CreateObject("Scripting.dictionary")
arrHeader = Array("Name", "Ext", "Ordner", "kB", "le.Änd.", "Erstellt", "Pfad", "Link")
lngColumns = UBound(arrHeader) + 1
prcFiles oFolder, oDictF
prcSubFolders oFolder, oDictF
On Error Resume Next
Set wksListe = ThisWorkbook.Sheets("DateiListe")
On Error GoTo 0
If wksListe Is Nothing Then
Set wksListe = Worksheets.Add(before:=Sheets(1))
wksListe.Name = "DateiListe"
End If
With wksListe
.Cells.Clear
.Cells(1, 1).Resize(, lngColumns) = arrHeader
.Cells(1, 1).Resize(, lngColumns).Font.Bold = True
If oDictF.Count > 0 Then
arrItems = oDictF.items
ReDim arrOut(1 To oDictF.Count, 1 To lngColumns)
For i = 0 To UBound(arrItems)
For j = 0 To UBound(arrItems(i))
arrOut(i + 1, j + 1) = arrItems(i)(j)
Next j
Next i
.Cells(2, 1).Resize(UBound(arrOut), UBound(arrOut, 2)).FormulaLocal = arrOut
Else
With .Cells(2, 1)
.Value = "No Files in " & oFolder
With .Font
.Bold = True
.Size = 16
.Color = RGB(255, 0, 0)
End With
End With
End If
.Columns.AutoFit
.Activate
End With
End Sub
Sub prcFiles(oFolder, oDictF)
Dim oFile As Object, sEXT As String
For Each oFile In oFolder.Files
sEXT = FSO.getextensionname(oFile)
Select Case LCase(sEXT)
Case "pdf", "xlsm"
With oFile
oDictF(.Path) = Array( _
Left(.Name, InStrRev(.Name, ".") - 1), _
Replace(.Name, Left(.Name, InStrRev(.Name, ".")), ""), _
oFolder.Name, _
Int(.Size / 1024), _
.DateLastModified, _
.DateCreated, _
.Path, _
"=HYPERLINK(""" & .Path & """;""" & "Klick" & """)")
End With
End Select
Next
End Sub
Sub prcSubFolders(oFolder, oDictF)
Dim oSubFolder As Object
For Each oSubFolder In oFolder.SubFolders
prcFiles oSubFolder, oDictF
prcSubFolders oSubFolder, oDictF
Next
End Sub
Gruß
Rudi

Anzeige
Danke =D
13.07.2016 10:50:35
baschti007
Hey
Rudi Danke

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige