Salvar arquivos no CD diretamente pelo Access

Amigos boa tarde!

Efetuando algumas buscar encontrei esse código que para mim é de grande valia pois uso muito o access para a automatização de processos e esse possibilita a gravação de arquivos em CD/DVD, etc... O código esta cru como encontrei e deixo aqui no intuito de quando da criação de rotinas para sua utilização seja partilhado aqui no forum para enriquecimento do conteúdo e conhecimento dos participantes. Para utilizá-lo tem que ser habilitada 2 referências no access que são:

- MICROSOFT IMAP2 BASE FUNCTIONALITY
- MICROSOFT IMAP2 FILE SYSTEM IMAGE CREATOR

Testei a rotina e funcionou perfeitamente...


Sub TestCDWrite()
Dim objDiscMaster As IMAPI2.MsftDiscMaster2
Dim objRecorder As IMAPI2.MsftDiscRecorder2
Dim DataWriter As IMAPI2.MsftDiscFormat2Data
Dim intDrvIndex As Integer
'The Object browser, but not intellisense, presents types for these, but they cannot be used in VBA
Dim stream As Variant
Dim FS As Variant
Dim Result As Variant
Dim FSI As Object
Dim strBurnPath As String
Dim strUniqueID As String

' *** CD/DVD disc file system types
Const FsiFileSystemISO9660 = 1
Const FsiFileSystemJoliet = 2
Const FsiFileSystemUDF102 = 4

'On Error GoTo TestCDWrite_Error

intDrvIndex = 0
strBurnPath = "C:\Toburn"
' Create a DiscMaster2 object to connect to optical drives.
Set objDiscMaster = New IMAPI2.MsftDiscMaster2

' Create a DiscRecorder2 object for the specified burning device.
Set objRecorder = New IMAPI2.MsftDiscRecorder2

strUniqueID = objDiscMaster.Item(intDrvIndex)
objRecorder.InitializeDiscRecorder (strUniqueID)

' Create a DiscFormat2Data object and set the recorder
Set DataWriter = New IMAPI2.MsftDiscFormat2Data
DataWriter.Recorder = objRecorder
DataWriter.ClientName = "IMAPIv2 TEST"
DataWriter.ForceMediaToBeClosed = True


' Create a new file system image object
Set FSI = New IMAPI2FS.MsftFileSystemImage


FS = FSI.ChooseImageDefaults(objRecorder)


' Add the directory and its contents to the file system
Call MsgBox("Adding " & strBurnPath & " folder to the disc. Press OK to continue.", vbInformation, "Burn Batch to CD")
FSI.Root.AddTree strBurnPath, False

' Create an image from the file system image object

Set Result = FSI.CreateResultImage()
Set stream = Result.ImageStream

' Write stream to disc using the specified recorder
Call MsgBox("Burn Batch to disc. Press OK to continue.", vbInformation, "Burn Batch to CD")
DataWriter.Write (stream)

Call MsgBox("Burn process completed.", vbInformation, "Burn Batch to CD")

ExitHere:
Exit Sub
'Error handling block
TestCDWrite_Error:
Select Case Err.Number
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "TestCode.TestCDWrite"
End Select
Resume ExitHere
'End Error handling block