vielleicht helfen dir diese Funktionen dabei:
Ich habe diese auf einem Access-Knowhow gefunden, aber die Sprache ist ja die gleiche...
Option Explicit
'**********************************************************************************
' Deklarationen CD-Laufwerk (um keine Fehlermeldung zu provozieren, wenn keine CD drinliegt
'**********************************************************************************
Declare Function SetErrorMode Lib "kernel32" (ByVal wMode As Long) As Long
'Declare Function SetErrorMode Lib "Kernel" (ByVal wMode As Integer) As Integer
Const SEM_FAILCRITICALERRORS = &H1
'**********************************************************************************
' Deklarationen CD-Laufwerk (um die Tür zu öffnen)
'**********************************************************************************
Private Declare Function mciExecute Lib "Winmm.dll" (ByVal lpstrCommand As String) As Long
'**********************************************************************************
' Deklarationen CD-Laufwerk
'**********************************************************************************
Private Declare Function mciSendString Lib "Winmm.dll" _
Alias "mciSendStringA" _
(ByVal lpstrCommand As String, ByVal _
lpstrReturnString As String, ByVal _
uReturnLength As Long, ByVal _
hwndCallback As Long) As Long
'Das Original-Posting stammt von merlin@camelot.shnet.org (Claus
'Lerch) und funktioniert ausgezeichnet:
'Drive muß 2-stellig z.B: "F:" angegeben werden
Function CDNum(Drive As String) As String
On Error GoTo CDNum_Err
Dim cdfile As String * 44
Dim I As Integer
If Dir$(Drive & "\Track01.CDA") = "" Then
CDNum = ""
Exit Function
End If
Open Drive & "\Track01.CDA" For Binary Shared As #1
Get 1, , cdfile
CDNum = Format$(Asc(Mid$(cdfile, 25, 1)), "000") _
& Format$(Asc(Mid$(cdfile, 26, 1)), "000") _
& Format$(Asc(Mid$(cdfile, 27, 1)), "000")
Close 1
Exit Function
CDNum_Err:
If Err = 76 Then
If MsgBox("Bitte CD einlegen und Laufwerk schliessen.", _
1 + 64, "CD-Info") = 1 Then
Resume
Else
CDNum = ""
Exit Function
End If
Else
MsgBox Error$, 64, "Fehlernummer: " & Str(Err)
On Error Resume Next
Close 1
Exit Function
End If
End Function
'Die Nummer ist in Byte 25-27 als ASCII-Zeichen in jedem .CDA-File
'abgelegt. Die Werte als Zeichenkette hintereinandergehaengt geben
'die Nummer.
'
'Im uebrigen kann man aus Byte 42 und 43 die Laenge jedes Tracks
'ermitteln.
'Drive muß 2-stellig z.B: "F:" angegeben werden
Function TrackLength(Drive As String, TrackNum As Integer) As Double
On Error GoTo TrackLength_Err
Dim cdfile As String * 44
Dim I As Integer
If Dir$(Drive & "\Track" & Format(TrackNum, "00") & ".CDA") = "" Then
MsgBox "Spur " & Format(TrackNum, "00") & _
" nicht vorhanden", 64, "CD-Info"
Exit Function
End If
Open Drive & "\Track" & Format(TrackNum, "00") & _
".CDA" For Binary Shared As #1
Get 1, , cdfile
TrackLength = TimeSerial(0, Asc(Mid$(cdfile, 43, 1)), _
Asc(Mid$(cdfile, 42, 1)))
Close 1
Exit Function
TrackLength_Err:
If Err = 76 Then
If MsgBox("Bitte CD einlegen und Laufwerk schliessen.", _
1 + 64, "CD-Info") = 1 Then
Resume
Else
Exit Function
End If
Else
MsgBox Error$, 64, "Fehlernummer: " & Str(Err)
Exit Function
End If
End Function
''''''-----
'From: "Uwe Weineck" Function MCISend(ByVal cmd$, Ret$) Dim RetSend As Long End Function 'Folgende Aufrufe helfen fuer den Anfang (koennen Sub CDAuf(CDAufx As Boolean) 'Das CD-ROM Laufwerk trägt als MCI-Gerät die Bezeichnung "CDaudio". If CDAufx Then End Sub '--------------- 'Paul Franke schrieb:
'Mittels der API-Funktion MCISendString ist dies moeglich,
'sofern man auch die zahlreichen MCI-Befehle zum Ansteuern
'von AudioCD 's parat hat (leider kann ich sie nicht alle hier
'auflisten, sie sind aus einem Uralt-Buch fuer VisualBasic 3.0
'und leider weiss ich auch nicht, wo man eine komplette
'Liste darueber bekommt - vielleicht ueber die MicroSoft Homepage??)...
'Setze ins Deklarationsteil eines VB-Moduls:
'Declare Function mciSendString Lib "winmm.dll" _Alias "mciSendStringA" _
'(ByVal lpstrCommand As String, ByVal _lpstrReturnString As String, ByVal _
'uReturnLength As Long, ByVal _hwndCallback As Long) As Long
'Nimm fuer den Anfang diese Funktion (faengt leider keine Fehler ab):
Dim InfoStr As String * 255
cmd$ = cmd$ + Chr$(0)
RetSend = mciSendString(cmd$, InfoStr, 255, 0)
Ret$ = Left$(InfoStr, InStr(InfoStr, Chr$(0)) - 1)
'auch im Testfenster ausprobiert werden, nachdem
'das Modul kompiliert und initialisiert worden ist).
'Damit eine AudioCD ueberhaupt abgespielt werden
'kann, *muessen* die ersten 2 Befehle auf jeden Fall
'immer aufgerufen werden = "Oeffnen" des CD-Spielers
'und Bestimmen des Abspielmodus):
'MCISend ( "open cdaudio alias cd", ret$ ) 'Oeffnen CDSpieler
'MCISend ( "set cd time format tmsf", ret$ ) 'Abspielformat setzen
'MCISend ("play cd from 3 to 4", ret$) ' z.B. spielt Titel Nr. 3
'Weitere Befehlssequenzen:"stop cd" = cd anhalten
'"pause cd" = unterbrechen, weiter mit "play cd"
'"close cd" = cd spieler schliessen; wieder oeffnen
' Mit "open cdaudio alias cd"
'Einige Status-Abfragen (Uebergabe an Variable ret$):
'Print MCISend("Status cd current track", Ret$) 'gibt
' gerade abgespielte Titelnr. zurueck
'Print MCISend("status cd length", Ret$) ' CD-Gesamtlaenge
'usw. usw. --- Es gibt weitere Befehle fuer Ermittlung Titelanzahl,
'Tilellaenge, CD-Spieler bereit ja/nein etc. etc.
'Fazit: Mit diesen Befehlen waere u. U.ein kompletter CD Audio Spieler
'unter Access machbar
'Gruss Uwe Weineck
'CDAufx = True = Tür auf
'CDAufx = False = Tür zu
'Sie können also folgende Befehle an dieses Gerät schicken:
'Aus www.basicword.com
Call mciExecute("Set CDaudio door open") ' Laufwerkstür öffnen
Else
Call mciExecute("Set CDaudio door closed") ' Laufwerkstür schließen
End If
'>Leider funktioniert die Prozedur für den erfolglosen CD-ROM Zugriff>nicht!>
'>Sie hat zur Folge, daß eine System-Fehlermeldung: "Windows kann nicht
'>von Laufwerk E: lesen" erscheint.
'Karl Donaubauer:
'Möglich, daß der Critical-Error-Handler eingestellt werden muß. Ich kann's
'nicht wirklich nachvollziehen, weil es bei mir nie notwendig war, aber nach
'Tips von Volker Werhahn und Marco Fiedler sollte es so funktionieren:
'Im Deklarationsteil des Moduls (also unterhalb von "Option Compare
'DATABASE ") ist der Aufruf der Win16-API-Funktion einzufügen und kann"
'eine Konstante gesetzt werden:- - - - -
'Declare Function SetErrorMode Lib "kernel32" (ByVal wMode As Long) As Long
'16 Bit: (Access 2)
'Declare Function SetErrorMode Lib "Kernel" (ByVal wMode As Integer) As Integer
'Const SEM_FAILCRITICALERRORS = &H1
'- - - - -Die Funktion sollte dann so aussehen:
'--------------------------------------------------------------------------
'Function such() ' irgendwo vor dem kritischen Dir-Befehl
'Dim OldValue As Long
'Dim Dummy As Long
'OldValue = SetErrorMode(SEM_FAILCRITICALERRORS)
'On Error GoTo Err_such
'pf = DLookup("[cd-Rom]", "t_kundendat", "[id]=1")
'dat = pf & ":\id1997.txt"
'Tref = Dir(dat)
'If Len(Tref) = 0 Then
' MsgBox "Bitte prüfen Sie, ob die XY CD-ROM eingelegt ist !", 48, "Hinweis"
' End If ' weiß nicht, ob das hier noch was bringt - evtl. weglassen
'Dummy = SetErrorMode(OldValue)
'Exit_such:
' Exit Function
'Err_such:
' If Err = 71 Then Beep: MsgBox "Es ist keine CD eingelegt !"
' Exit Function ' bei Resume Next kämen beide MsgBoxenEnd Function
'----------------------------------------------------------------------------
'HTH
'Karl Donaubauer
Gruß
Steffen D
Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden
Suche nach den besten AntwortenEntdecke unsere meistgeklickten Beiträge in der Google Suche
Top 100 Threads jetzt ansehen