Dave
12-17-2010, 09:00 PM
I cobbled together some "borrowed" code with a bit of added stuff to create a VBA CD burn routine. I've trialled it successfully with Vista and office versions 03 and 07. I would really appreciate any feedback from anyone with either different operating systems (ie. XP. 2000, 07 etc) or different office versions (ie. 97, 2010, etc.). Thanks. Dave
Sub BurnCD(FileName As String, FileLocation As String, CdDriveLetter As String)
'eg Call BurnCD("Test.doc", "D:\", "E:\")
'eg. Call BurnCD("test.xls", "C:\testfolder\", "E:\")
Dim WShshell As Object, ObjShell As Object, WScript As Variant
Dim StrBurnDirectory As Variant, ObjFolder As Object, OfsObj As Object
Dim StrSourceDirectory As Variant, TempInt As Integer, TestDir As Variant
'burns file to CD
On Error GoTo ErFix
Set OfsObj = CreateObject("Scripting.FilesystemObject")
'check if file exists
If OfsObj.fileexists(FileLocation & FileName) <> True Then
MsgBox "The file: " & FileLocation & FileName & " does not exist!"
Set OfsObj = Nothing
Exit Sub
End If
'check if Drive exists. Check if Drive is ready
With OfsObj
If .Driveexists(Left(CdDriveLetter, 2)) = False Then
MsgBox "You do not have a directory: " & CdDriveLetter
Set OfsObj = Nothing
Exit Sub
End If
If .Drives(Left(CdDriveLetter, 2)).IsReady = False Then
MsgBox "Please insert a disk in directory: " & CdDriveLetter, vbOKCancel
Set OfsObj = Nothing
Exit Sub
End If
End With
'check to see if Directory is CD
TempInt = GetAttr(CdDriveLetter) And vbReadOnly
If TempInt <> 1 Then
MsgBox "The Directory: " & CdDriveLetter & " is NOT a cd directory"
Set OfsObj = Nothing
Exit Sub
'Else
'MsgBox "This Directory: " & CdDriveLetter & " is a cd directory"
End If
'create temp folder
If OfsObj.folderexists("C:\TmpBurnFolder") <> True Then
OfsObj.createfolder ("C:\TmpBurnFolder")
End If
'copy file to be burned to temp folder
OfsObj.CopyFile FileLocation & FileName, "C:\TmpBurnFolder\", True
'move file to burn location
Const MY_COMPUTER = &H11
StrSourceDirectory = "C:\TmpBurnFolder"
Set WShshell = CreateObject("WScript.Shell")
Set ObjShell = CreateObject("Shell.Application")
StrBurnDirectory = WShshell.RegRead( _
"HKCU\Software\Microsoft\Windows\CurrentVersion\" _
& "Explorer\Shell Folders\CD Burning")
Set ObjFolder = ObjShell.Namespace(StrSourceDirectory)
ObjShell.Namespace(StrBurnDirectory).CopyHere ObjFolder.Items
'copy file from burn location to cd
'If error occurs CD directory is read only
On Error Resume Next
OfsObj.CopyFile StrBurnDirectory & "\" & FileName, _
CdDriveLetter & FileName, True
If Err.Number <> 0 Then
MsgBox "You can NOT write to the CD directory: " & CdDriveLetter
GoTo ErFix
End If
'clean up
Kill StrBurnDirectory & "\" & FileName
OfsObj.deletefolder ("C:\TmpBurnFolder"), False
Set OfsObj = Nothing
Set ObjFolder = Nothing
Set ObjShell = Nothing
Set WShshell = Nothing
MsgBox "The file: " & CdDriveLetter & FileName & " is ready."
Exit Sub
ErFix:
On Error GoTo 0
MsgBox "CD Burn error!"
Kill StrBurnDirectory & "\" & FileName
If OfsObj.folderexists("C:\TmpBurnFolder") = True Then
OfsObj.deletefolder ("C:\TmpBurnFolder"), False
End If
Set OfsObj = Nothing
Set ObjFolder = Nothing
Set ObjShell = Nothing
Set WShshell = Nothing
End Sub
Sub BurnCD(FileName As String, FileLocation As String, CdDriveLetter As String)
'eg Call BurnCD("Test.doc", "D:\", "E:\")
'eg. Call BurnCD("test.xls", "C:\testfolder\", "E:\")
Dim WShshell As Object, ObjShell As Object, WScript As Variant
Dim StrBurnDirectory As Variant, ObjFolder As Object, OfsObj As Object
Dim StrSourceDirectory As Variant, TempInt As Integer, TestDir As Variant
'burns file to CD
On Error GoTo ErFix
Set OfsObj = CreateObject("Scripting.FilesystemObject")
'check if file exists
If OfsObj.fileexists(FileLocation & FileName) <> True Then
MsgBox "The file: " & FileLocation & FileName & " does not exist!"
Set OfsObj = Nothing
Exit Sub
End If
'check if Drive exists. Check if Drive is ready
With OfsObj
If .Driveexists(Left(CdDriveLetter, 2)) = False Then
MsgBox "You do not have a directory: " & CdDriveLetter
Set OfsObj = Nothing
Exit Sub
End If
If .Drives(Left(CdDriveLetter, 2)).IsReady = False Then
MsgBox "Please insert a disk in directory: " & CdDriveLetter, vbOKCancel
Set OfsObj = Nothing
Exit Sub
End If
End With
'check to see if Directory is CD
TempInt = GetAttr(CdDriveLetter) And vbReadOnly
If TempInt <> 1 Then
MsgBox "The Directory: " & CdDriveLetter & " is NOT a cd directory"
Set OfsObj = Nothing
Exit Sub
'Else
'MsgBox "This Directory: " & CdDriveLetter & " is a cd directory"
End If
'create temp folder
If OfsObj.folderexists("C:\TmpBurnFolder") <> True Then
OfsObj.createfolder ("C:\TmpBurnFolder")
End If
'copy file to be burned to temp folder
OfsObj.CopyFile FileLocation & FileName, "C:\TmpBurnFolder\", True
'move file to burn location
Const MY_COMPUTER = &H11
StrSourceDirectory = "C:\TmpBurnFolder"
Set WShshell = CreateObject("WScript.Shell")
Set ObjShell = CreateObject("Shell.Application")
StrBurnDirectory = WShshell.RegRead( _
"HKCU\Software\Microsoft\Windows\CurrentVersion\" _
& "Explorer\Shell Folders\CD Burning")
Set ObjFolder = ObjShell.Namespace(StrSourceDirectory)
ObjShell.Namespace(StrBurnDirectory).CopyHere ObjFolder.Items
'copy file from burn location to cd
'If error occurs CD directory is read only
On Error Resume Next
OfsObj.CopyFile StrBurnDirectory & "\" & FileName, _
CdDriveLetter & FileName, True
If Err.Number <> 0 Then
MsgBox "You can NOT write to the CD directory: " & CdDriveLetter
GoTo ErFix
End If
'clean up
Kill StrBurnDirectory & "\" & FileName
OfsObj.deletefolder ("C:\TmpBurnFolder"), False
Set OfsObj = Nothing
Set ObjFolder = Nothing
Set ObjShell = Nothing
Set WShshell = Nothing
MsgBox "The file: " & CdDriveLetter & FileName & " is ready."
Exit Sub
ErFix:
On Error GoTo 0
MsgBox "CD Burn error!"
Kill StrBurnDirectory & "\" & FileName
If OfsObj.folderexists("C:\TmpBurnFolder") = True Then
OfsObj.deletefolder ("C:\TmpBurnFolder"), False
End If
Set OfsObj = Nothing
Set ObjFolder = Nothing
Set ObjShell = Nothing
Set WShshell = Nothing
End Sub