DVD Brennen aus VBA
10.11.2021 21:37:19
Andreas
ich versuche nochmal mein Glück, nachdem der erste Beitrag zu dem Thema bereits einige Tage her ist und keine Antwort gefunden werden konnte.
Mit nachfolgendem Code brenne ich eine DVD, was auch prima klappt. Startet man das Makro fragt er, ob gebrannt werden soll. Er öffnet dann die DVD Schublade automatisch und wartet derzeit, bis ich die CD eingelegt habe und dann auf OK geklickt habe. Ich würde gerne die Msgbox umgehen, zb durch ein Userform, das automatisch geschlossen wird, wenn der User auch mechanisch das Laufwerk schließt. Kann man das irgendwie erkennen, dass das Laufwerk manuell geschlossen wurde ?
Vielen Dank
Public Function Brenne_DVD(ByVal path As String, ByVal TextBox3 As String)
Dim Index ' Index to recording drive.
Dim Recorder ' Recorder object
Dim Stream ' Data stream for burning device
Dim g_DiscMaster
Dim FSI ' Disc file system
Dim Dir ' Root directory of the disc file system
Dim dataWriter
Dim result
Dim uniqueId
Index = 0 ' First and only drive on the system
Call mciExecute("Set CDaudio door open")
MsgBox "Bitte einen Datenträger (CD/DVD) in das Laufwerk einlegen und bestätigen.", vbInformation, "Elektronisches Tagebuch"
Call mciExecute("Set CDaudio door closed")
Call UF_Brennvorgang.Show
Set g_DiscMaster = CreateObject("IMAPI2.MsftDiscMaster2")
Set Recorder = CreateObject("IMAPI2.MsftDiscRecorder2")
uniqueId = g_DiscMaster.Item(Index)
Recorder.InitializeDiscRecorder (uniqueId)
Set FSI = CreateObject("IMAPI2FS.MsftFileSystemImage")
Set Dir = FSI.Root
'Create the new disc format and set the recorder
Set dataWriter = CreateObject("IMAPI2.MsftDiscFormat2Data")
dataWriter.Recorder = Recorder
dataWriter.ClientName = "IMAPIv2 TEST"
FSI.ChooseImageDefaults (Recorder)
FSI.VolumeName = TextBox3
' Add the directory and its contents to the file system
Dir.AddTree path, False
' Create an image from the file system
Set result = FSI.CreateResultImage()
' Write stream to disc using the specified recorder.
On Error GoTo Errorhandler:
dataWriter.Write (result.ImageStream)
Call Unload(Object:=UF_Brennvorgang)
Call mciExecute("Set CDaudio door open")
MsgBox ("Brennvorgang erfolgreich beendet." & Chr(10) & "Bitte Datenträger entnehmen und beschriften."), vbInformation
Exit Function
Errorhandler:
Call Unload(Object:=UF_Brennvorgang)
Call mciExecute("Set CDaudio door open")
MsgBox ("Der Vorgang konnte nicht ordnungsgemäß abgeschlossen werden." & Chr(10) & Chr(10) & "Bitte prüfen Sie den Datenträger."), vbCritical
End Function