I'm using MS Access 2003 and am running a VBA script that will
retrieve an inventory status report from an email. The attachment in
the email is a .zip file and I'm try to replace it in a folder.
I have 2 problems:
1) The file ends up adding more sub folders;
Inventory Reports\filename\apps\prforte\edi_sql\kfs
and I don't know how to get rid of it
2) When I use copyhere method I get a dialog box asking me to hit YES
to all. Is there some reference library that I do not have in my code
that I need to add? I know that &H10& is supposed to get rid of that
message but I haven't been able to get it to work. Also I have no
idea how to use XCOPY.
Please help, here is my code:
Sub Unzip2()
DoCmd.SetWarnings False
Dim myNamespace As Outlook.Namespace
Dim myMAPIFolder As Outlook.MAPIFolder
Dim mybinboxFolder As Outlook.MAPIFolder
Dim objItems As Outlook.Items
Dim lngX As Long
'Dim ASNFolder As Outlook.MAPIFolder
Set myNamespace = Outlook.GetNamespace("MAPI")
Set myMAPIFolder = myNamespace.Folders("Mailbox - Group Box")
Set mybinboxFolder = myMAPIFolder.Folders("Inbox")
Set objItems = mybinboxFolder.Items
'Set ASNFolder = mybinboxFolder.Folders("Deleted Items")
mybinboxFolder.GetExplorer
For Each omsg In objItems
'exists for any possible subject.
If omsg.Attachments.Count > 0 Then
If omsg.Subject = "Inventory Status Report" Then
For Each oattachment In omsg.Attachments
Dim FSO As Object
Dim oApp As Object
Dim fname
Dim FileNameFolder
Dim DefPath As String
dtmMyDate = Format(Now(), "mm-dd-yyyy hh-mm-
ss")
If Left(Right(dtmMyDate, 8), 2) < 12 Then
dtmMyDate = dtmMyDate & " am"
Else
dtmMyDate = dtmMyDate & " pm"
End If
fname = "D:\Inventory Reports\" & dtmMyDate &
".zip"
oattachment.SaveAsFile fname
DefPath = "D:\Inventory Reports\" '<<< Change path
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
FileNameFolder = DefPath
Set oApp = CreateObject("Shell.Application")
Const FOF_CREATEPROGRESSDLG = &H10&
'Copy the files in the newly created folder
oApp.Namespace(FileNameFolder).CopyHere
oApp.Namespace(fname).Items, FOF_CREATEPROGRESSDLG
'oApp.Namespace(FileNameFolder).CopyHere
oApp.Namespace(fname).Items
On Error Resume Next
Set FSO =
CreateObject("scripting.filesystemobject")
FSO.deletefolder Environ("Temp") & "\Temporary
Directory*", True
Set oApp = Nothing
Set FSO = Nothing
'omsg.Move ASNFolder
Next
End If
End If
Next
DoCmd.SetWarnings True
'--------------------ZIP
PORTION----------------------------------------
End Sub