Prüfung ob Datenträger im Laufwerk / Schleife
28.09.2004 13:23:53
Jens
Ich komme mit meinen wenigen angelernten VBA-Bruchstücken trotz Recherchen jetzt nicht weiter; vielleicht kann mir jemand bei folgendem Problem helfen:
Im Verlauf des Makros (=Datenauslesen) soll geprüft werden, ob überhaupt ein Datenträger im Default-Laufwerk (CDRom) liegt oder nicht; wenn nicht, springt ein Verzeichnisbaum-Fenster auf, in dem dann ein anderes Verzeichnis gewählt werden kann.
Ich frage nun mit Hilfe einer Funktion ab, ob ein Datenträger drin liegt (ja = 1, nein = 0), aber im Makro wird immer der Wert 0 übertragen, egal ob ein Datenträger drin liegt oder nicht.
An dieser Stelle komme ich nicht weiter und benötige Hilfe. Der Rest läuft soweit.
Vielen Dank schon mal und viele Grüße,
Jens
******************************************************************************
Private Sub DateienAuslesen()
Dim shNew As Worksheet
Dim intRow As Integer
Dim i As Integer
Dim e As String
Dim j As Integer
Dim z As Integer
Dim iAnz As Integer
Dim Bereich As Range
Dim Bereich2 As Range
Dim intPos As Integer
Dim strDateiMitExt As String
Dim intPostPunkt As Integer
Dim strDateiname As String
Dim Zelle As Range
Dim Leerz As Integer
Dim CD As String
Dim Song As String
Dim s As String
Dim n As String
Dim nVerz As String
Dim DatenträgerDrin As Integer
'Einfügen neues Tabellenblatt und benennen
10 t = InputBox(prompt:="Geben Sie bitte die Blatt-Bezeichnung für die mp3-CD/DVD ein:" & Chr(10) & _
"(lfd. Nrn. wg. Sortierung bitte mit führender Null)", Title:="Blattname für mp3-Dateien:", _
Default:="mp3-CD 01")
If t = "" Then Exit Sub
On Error Resume Next
Set shNew = Worksheets(t)
If Err > 0 Or shNew Is Nothing Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = t
Worksheets(t).Select
Else
Beep
MsgBox "Name besteht schon! Bitte anderen wählen!"
GoTo 10
End If
'Verzeichnis auslesen
s = CdRomLWBuchstabe()
e = InputBox(prompt:="Geben Sie bitte den gewünschten Pfad ein:" & Chr(10) & _
"(Beispiel E:\ )" & Chr(10) & " " & Chr(10) & "Default: CDRom-Laufwerk" & Chr(10) & _
" " & Chr(10) & "Anderes Verzeichnis: abbrechen oder Default-Verzeichnis löschen", _
Title:="mp3-Dateien auslesen", Default:=s)
If Right(e, 1) <> "\" Then GoTo 12 'bei verstümmelter LW-Angabe
'Es fehlt Code für: Wenn kein Datenträger im Laufwerk, dann springe zu 12 (Verzeichnisbaum)
'****** HIER komme ich nicht weiter, egal ob mit if... oder case ...
DatenträgerDrin = ShowDriveInfo(e)
'If DatenträgerDrin = 1 Then GoTo 11
'If DatenträgerDrin = 0 Then GoTo 12
Select Case DatenträgerDrin
Case Is = 1
GoTo 11
Case Is = 0
GoTo 12
End Select
Select Case e
Case Is <> ""
GoTo 11
Case Is = 0
GoTo 12
Case Is = ""
GoTo 12
End Select
'---Auswahl des Default-Verzeichnisses:
11 i = 1
With Application.FileSearch
.NewSearch
.LookIn = e
.FileName = "*.mp3"
.SearchSubFolders = True
If .Execute() > 0 Then
For Each varFile In .FoundFiles
Cells(i, 1).Value = varFile
i = i + 1
Next varFile
MsgBox "Im Verzeichnis " & .LookIn & " wurden " & .FoundFiles.Count & " Dateien gefunden."
Else: MsgBox "Im Verzeichnis " & .LookIn & " wurden keine Dateien gefunden."
Application.DisplayAlerts = False
ActiveSheet.Delete
Exit Sub
End If
End With
Application.ScreenUpdating = False
Columns("A:A").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Selection.Replace what:=e, Replacement:="", lookat:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
GoTo 14
'---Auswahl eines Alternativ-Verzeichnisses:
12 n = MsgBox(prompt:="Fehlerhafte Verzeichnisangabe, fehlender Datenträger im" & Chr(10) & _
"CDRom-Laufwerk oder anderes Verzeichnis gewünscht." & Chr(10) & _
"" & Chr(10) & _
"Wählen Sie ein anderes Verzeichnis aus!", Title:="Hinweis:")
nVerz = VerzeichnisErmitteln(n)
If nVerz = "" Then Exit Sub
Application.ScreenUpdating = False
i = 1
With Application.FileSearch
.NewSearch
.LookIn = nVerz
.FileName = "*.mp3"
.SearchSubFolders = True
If .Execute() > 0 Then
For Each varFile In .FoundFiles
Cells(i, 1).Value = varFile
i = i + 1
Next varFile
MsgBox "Im Verzeichnis " & .LookIn & " wurden " & .FoundFiles.Count & " Dateien gefunden."
Else: MsgBox "Im Verzeichnis " & .LookIn & " wurden keine Dateien gefunden."
Application.DisplayAlerts = False
ActiveSheet.Delete
Exit Sub
End If
End With
Columns("A:A").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
intPos = InStrRev(nVerz, "\", , vbTextCompare)
strDateiMitExt = Right(nVerz, Len(Zelle) - intPos)
intPostPunkt = InStrRev(strDateiMitExt, ".", , vbTextCompare)
CD = Left(nVerz, intPos - 1)
Selection.Replace what:=CD & "\", Replacement:="", lookat:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
'---------hier gehts weiter
14 Set Bereich = Range("A:A")
For Each Zelle In Bereich
If IsEmpty(Zelle) Then Exit For
intPos = InStrRev(Zelle, "\", , vbTextCompare)
strDateiMitExt = Right(Zelle, Len(Zelle) - intPos)
intPostPunkt = InStrRev(strDateiMitExt, ".", , vbTextCompare)
strDateiname = Left(strDateiMitExt, intPostPunkt - 1)
CD = Left(Zelle, intPos - 1)
Song = strDateiname
Zelle = CD
Zelle.Offset(0, 1) = Song
Next
Columns("B:B").Replace what:=".mp3", Replacement:="", lookat:=xlPart, _
SearchOrder:=xlByColumns, MatchCase:=False
Range("A1").Select
Selection.EntireRow.Insert
Range("A2").Select
With ActiveCell
.Copy
.Offset(-1, 1).PasteSpecial Paste:=xlValues
End With
Columns("A:B").Font.Bold = False
z = 1
ActiveCell.Offset(0, -1) = z
Range(ActiveCell.Offset(0, -1), ActiveCell).Font.Bold = True
z = z + 1
Range("A2").Activate
Do Until ActiveCell.Value = "" And ActiveCell.Offset(1, 0) = ""
If ActiveCell.Value <> ActiveCell.Offset(1, 0).Value Then
ActiveCell.Offset(1, 0).Activate
Selection.EntireRow.Insert
With ActiveCell
.Offset(1, 0).Copy
.Offset(0, 1).PasteSpecial Paste:=xlValues
End With
ActiveCell.Offset(0, -1) = z
Range(ActiveCell.Offset(0, -1), ActiveCell).Font.Bold = True
z = z + 1
Rows(ActiveCell.Row & ":" & ActiveCell.Row).Insert
ActiveCell.Offset(2, -1).Select
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
ActiveCell.Offset(-1, 0).ClearContents
'übrig gebliebene CD-Titel löschen:
intRow = Cells(Rows.Count, 2).End(xlUp).Row
For Each Cell In Range("A2:A" & intRow)
If IsNumeric(Cell) = False Then Cell.ClearContents
Next
Columns("A:A").ColumnWidth = 3.5
Columns("B:B").ColumnWidth = 60
Columns("C:C").ColumnWidth = 10
Columns("D:D").ColumnWidth = 3.5
Columns("E:E").ColumnWidth = 60
Application.ScreenUpdating = True
ActiveSheet.Protect ("mp3")
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function CdRomLWBuchstabe() As String
Dim lLWTyp As Long
Dim sLW As String
Dim l As Long
Dim l1 As Long
Dim sBuffer As String
sBuffer = Space(200)
l = GetLogicalDriveStrings(200, sBuffer)
If l = 0 Then
CdRomLWBuchstabe = vbNullString
Exit Function
End If
l1 = 1
sLW = Mid(sBuffer, l1, 3)
Do While (Mid(sBuffer, l1, 1) vbNullChar)
lLWTyp = GetDriveType(sLW)
If lLWTyp = 2 Then 'alt 5 xxx testweise z.z. auf A:\ umgestellt!
CdRomLWBuchstabe = sLW
Exit Function
End If
l1 = l1 + 4
sLW = Mid(sBuffer, l1, 3)
Loop
End Function
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Function ShowDriveInfo(drvpath) As String
Dim fs, d, s, t
Dim DatenträgerDrin 'As Integer
Set fs = CreateObject("Scripting.FileSystemObject")
Set d = fs.GetDrive(drvpath)
Select Case d.DriveType
Case 0: t = "Unknown"
Case 1: t = "Removable"
Case 2: t = "Fixed"
Case 3: t = "Network"
Case 4: t = "CD-ROM"
Case 5: t = "RAM Disk"
End Select
s = "Drive " & d.DriveLetter & ": - " & t
If d.IsReady Then
DatenträgerDrin = 1
s = s & vbCrLf & "Drive is Ready."
Else
DatenträgerDrin = 0
s = s & vbCrLf & "Drive is not Ready."
End If
MsgBox s 'zum Testen
End Function