Live-Forum - Die aktuellen Beiträge
Datum
Titel
25.04.2024 00:42:03
Listbox mit gefilterten Daten füllen
24.04.2024 20:38:58
Summe mit Bedingung, nur letzte Ergebnisse anzeigen
24.04.2024 19:29:30
Formel filter
24.04.2024 18:49:56
merge & select
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1856to1860
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1856to1860
1856to1860
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

DVD Brennen aus VBA

DVD Brennen aus VBA
10.11.2021 21:37:19
Andreas
Hallo alle zusammen,
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

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: DVD Brennen aus VBA
11.11.2021 09:10:27
Nepumuk
Hallo Andreas,
teste mal:

Option Explicit
Private Declare PtrSafe Sub Sleep Lib "kernel32.dll" ( _
ByVal dwMilliseconds As Long)
Public Sub Beispiel()
Dim objWMIService As Object, obColItems As Object, objItem As Object
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Do
Set obColItems = objWMIService.ExecQuery("Select * from Win32_CDROMDrive")
For Each objItem In obColItems
If objItem.MediaLoaded Then Exit Do
Next
Call Sleep(500)
DoEvents
Loop
MsgBox "Weiter geht's"
End Sub
Gruß
Nepumuk
AW: DVD Brennen aus VBA
11.11.2021 09:41:37
Andreas
Hallo Nepumuk,
danke für Deinen Code. Helf mir mal kurz, wie ich den mit meinem Code verknüpfe....? Komm da jetzt nicht ganz mit, wie du dir das gedacht hast ?
Anzeige
AW: DVD Brennen aus VBA
11.11.2021 09:47:26
Nepumuk
Hallo Andreas,
den baust du nach dieser Zeile:
Call mciExecute("Set CDaudio door closed")
ein.
Gruß
Nepumuk
AW: DVD Brennen aus VBA
11.11.2021 09:49:14
Andreas
Ich habe es mal an diese Stelle gesetzt und die MSGbox vorher rausgenommen. Hast Du das so gemeint ?
Das klappt auch, solange man eine CD einlegt. Wenn jemand aber keine CD einlegt, wie kann ich dann erkennen, dass jetzt keine Medium im Laufwerk ist und ggf abbrechen?
...
Call mciExecute("Set CDaudio door open")
'MsgBox "Bitte einen Datenträger (CD/DVD) in das Laufwerk einlegen und bestätigen.", vbInformation, "Elektronisches Tagebuch"
Call Beispiel
...
Anzeige
AW: DVD Brennen aus VBA
11.11.2021 10:00:15
Nepumuk
Hallo Andreas.
so:

Option Explicit
Private Declare PtrSafe Sub Sleep Lib "kernel32.dll" ( _
ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function mciExecute Lib "winmm.dll" ( _
ByVal lpstrCommand As String) As Long
Public Sub 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
Dim objWMIService As Object, obColItems As Object, objItem As Object
Dim lngCounter As Long
Index = 0                      ' First and only drive on the system
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Do
Set obColItems = objWMIService.ExecQuery("Select * from Win32_CDROMDrive")
For Each objItem In obColItems
If objItem.MediaLoaded Then Exit Do
Next
Call Sleep(500)
DoEvents
lngCounter = lngCounter + 1
If lngCounter = 10 Then
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")
lngCounter = 0
End If
Loop
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 Sub
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 Su
Gruß
Nepumuk
Anzeige
AW: DVD Brennen aus VBA
11.11.2021 10:07:57
Andreas
Hey Nepumuk. Danke für Deine Bemühungen.
Die Msgbox nach dem Einlegen des Datenträgers, wenn ich manuell schließe, bleibt aber noch, solange ich kein OK gedrückt habe...Kann man das noch automatisieren, dass der dann das OK selbst bestätigt?
AW: DVD Brennen aus VBA
11.11.2021 11:46:19
Nepumuk
Hallo Andreas.
teste mal:

Option Explicit
Private Declare PtrSafe Sub Sleep Lib "kernel32.dll" ( _
ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function mciExecute Lib "winmm.dll" ( _
ByVal lpstrCommand As String) As Long
Private Declare PtrSafe Function MessageBoxTimeoutA Lib "user32.dll" ( _
ByVal hWnd As LongPtr, _
ByVal lpText As String, _
ByVal lpCation As String, _
ByVal uType As VbMsgBoxStyle, _
ByVal wLanguageId As Integer, _
ByVal dwMiliseconds As Long) As Long
Public Sub 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
Dim objWMIService As Object, obColItems As Object, objItem As Object
Dim lngCounter As Long
Index = 0                      ' First and only drive on the system
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Do
Set obColItems = objWMIService.ExecQuery("Select * from Win32_CDROMDrive")
For Each objItem In obColItems
If objItem.MediaLoaded Then Exit Do
Next
Call Sleep(500)
DoEvents
lngCounter = lngCounter + 1
If lngCounter = 10 Then
Call mciExecute("Set CDaudio door open")
Call MessageBoxTimeoutA(Application.hWnd, "Bitte einen Datenträger (CD/DVD) in das Laufwerk einlegen und bestätigen.", _
"Elektronisches Tagebuch", vbInformation, 0, 5000) '5000 = 5 Sekunden
Call mciExecute("Set CDaudio door closed")
lngCounter = 0
End If
Loop
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 Sub
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 Sub
Gruß
Nepumuk
Anzeige
AW: DVD Brennen aus VBA
11.11.2021 12:01:55
Andreas
Ich glaube wir reden gerade aneinander vorbei. Ich versuche es nochmal zu verdeutlichen. Eigentlich brauch ich nur eine Prüfung, die da heisst: "Wurde das Laufwerk (manuell) geschlossen"... dann raus aus der loop schleife und weiter. Ich habe mich auch noch bisschen weiter versucht und bin von der MEssagebox abgekommen. Mit deinem neuen Code macht er jetzt das Laufwerk auf und zu...
Schau mal, ob Du mir vl an diesem einen kleinen Punkt im Loop (ich habe es kommentiert) noch helfen kannst... Wüsste da nicht weiter...Dadurch, dass ich jetzt das USerform verwende, brauch ich keinen Klick mehr auf den OK Button. Ist einfacher und sieht noch hübscher aus. Aber wie erkennt er, dass die Schublade jetzt zu ist. Derzeit prüft er ja, ob nen Medium eingelegt wurde...

Public Sub 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
Dim objWMIService As Object, obColItems As Object, objItem As Object
Dim lngCounter As Long
Index = 0                      ' First and only drive on the system
Call UF_Brennvorgang.Show
UF_Brennvorgang.Label1 = "Bitte Datenträger einlegen und Laufwerk schließen"
Call mciExecute("Set CDaudio door open")
Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
Do
Set obColItems = objWMIService.ExecQuery("Select * from Win32_CDROMDrive")
For Each objItem In obColItems
If objItem.MediaLoaded Then Exit Do
'HIER müsste wohl was rein, dass erkennt, dass die Schublade geschlossen wurde. Derzeit prüft er ja, ob nen Medium eingelegt wurde....
Next
Call Sleep(500)
DoEvents
Loop
UF_Brennvorgang.Label1 = "Bitte warten, Datenträger wird gebrannt..."
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 Sub
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 Sub

Anzeige
AW: DVD Brennen aus VBA
11.11.2021 12:08:49
Nepumuk
Hallo Andreas.

'HIER müsste wohl was rein, dass erkennt, dass die Schublade geschlossen wurde. Derzeit prüft er ja, ob nen Medium eingelegt wurde....
und was, wenn dein User keim Medium eingelegt hat? Prüfen ob die Schublade geschlossen ist brauchst du nicht, das machst du doch per VBA:
Call mciExecute("Set CDaudio door closed")
Gruß
Nepumuk
AW: DVD Brennen aus VBA
11.11.2021 12:14:24
Andreas
Das soll ja das auslösende Ereignis sein. Das schließen mit Call mciExecute("Set CDaudio door closed") ist zwar schön, wenn er fein auf OK drückt, wenn er aber nicht drückt und manuell die Schublade schließt, dann wartet das mit der Msgbox vor sich hin und macht nicht weiter. Wenn er keine CD einlegt ist das nicht schlimm, am Ende landet er ja im Errorhandler, dass die CD nicht gebrannt werden konnte. Dann muss er halt nochmal das Makro, das über den CommandButton ausgelöst wird, neu starten.
Anzeige
AW: DVD Brennen aus VBA
11.11.2021 13:12:14
Andreas
kannst Du vielleicht damit was anfangen ? Hab ich von einer seite die sich mit VB beschäftigt / aber eben kein VBA.

For Each d As IO.DriveInfo In IO.DriveInfo.GetDrives
If d.DriveType = IO.DriveType.CDRom And d.IsReady = False Then
For Each i As String In ok
If i = d.Name Then
item = True
Exit For
End If
Next
If item = True Then
Console.WriteLine("Das CD-Rom Laufwerk " & d.Name & " ist offen !!!")
ok.Remove(d.Name)
End If
End If
Next
AW: DVD Brennen aus VBA
11.11.2021 13:19:54
Nepumuk
Hallo Andreas,
NEIN:
Ich bezweifle es stark, dass das jemals gelaufen ist. Diese Zeile:

For Each i As String In ok

kann nicht funktionieren.
Gruß
Nepumuk
Anzeige

Links zu Excel-Dialogen

TextBox UserForm

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige