DVD Brennfunktion sehr langsam
08.10.2023 05:57:38
Andreas
ich hoffe Ihr könnt mir bei nachfolgendem Code helfen. Mit diesem brenne ich schon eine ganze Weile einen indivuellen Ordner, was auch im Ergebnis tadellos funktioniert. Allerdings hat der Code einen kleinen Haken. Bis der Brennvorgang startet kann es bis zu 5 Minuten dauern, solange friert das Programm ein. Ich rede hierbei ausdrücklich von "Starten" - der Brennvorgang selbst läuft dann in angemessener Zeit. Mit Starten meine ich, bis ich die ersten Reaktionen am Brenner erhalte.
Wenn ich über Windows selbst brenne habe ich das Problem nicht... Kann mir jemand vl. einen Rat geben, woran das liegt? Und ja, ich weiss, Excel ist kein Brennprogramm - wenns nicht geht, dann ist das halt so. Es geht mir nur um Optimierung.
Lieben Dank Andreas
Public Sub Brenne_DVD(ByVal spfadAkte 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
Dim objWMIService As Object, objColItems As Object, objItem As Object
Dim lngCounter As Long
Dim DatenTraegBez As String
Index = 0 ' First and only drive on the system
Dim fs As Object
Dim F As Object
Dim OrdnerSize
Set fs = CreateObject("Scripting.FileSystemObject")
Set F = fs.GetFolder(spfadAkte)
Select Case F.Size
Case Is 700000000:
Call mciExecute("Set CDaudio door open")
Set objWMIService = GetObject("winmgmts:.rootcimv2")
'Set obColItems = objWMIService.ExecQuery("Select * from Win32_CDROMDrive")
Set objColItems = objWMIService.ExecQuery("Select * from Win32_LogicalDisk Where DriveType=2")
If MsgBox("Bitte einen passenden Datenträger (Anforderung:" & DatenTraegBez & ") in das Laufwerk einlegen und Schublade schließen. Möchten Sie den Brennvorgang des Ordners starten?", vbQuestion + vbYesNo, "Brennvorgang starten") = vbNo Then GoTo ERRORHANDLER
Application.DisplayAlerts = False
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 spfadAkte, 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")
Application.DisplayAlerts = True
MsgBox ("Brennvorgang erfolgreich beendet." & Chr(10) & "Bitte Datenträger entnehmen und beschriften."), vbInformation, "Brennen"
Call LogEintrag(TextBox3 & ": DVD erfolgreich gebrannt.")
Exit Sub
ERRORHANDLER:
Call Unload(Object:=UF_Brennvorgang)
Call mciExecute("Set CDaudio door open")
Application.DisplayAlerts = True
MsgBox ("Der Vorgang konnte nicht ordnungsgemäß abgeschlossen werden." & Chr(10) & Chr(10) & "Bitte Datenträger überprüfen und Vorgang wiederholen."), vbCritical, "Brennen"
Call LogEintrag(TextBox3 & ": DVD nicht erfolgreich gebrannt.")
CancelCD = False
End Sub