Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders("NDucanh@agilitylogistics.com").Folders("Inbox")
''ns.GetDefaultFolder(olFolderInbox)
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Function
End If
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
If (GetExtName(Atmt.FileName) = "msg") Then
FileName = "C:\ATT\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Function
On Error GoTo GetAttachments_err
GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
End Function
Function GetExtName(ScanString As String) As String
'*******************************************************
'
' directory path
'
'
'
'
' Full Filepath incl. Filename
'
'
'
'*******************************************************
Dim intPos As String
Dim intPosSave As String
If InStr(ScanString, ".") = 0 Then
GetExtName = ""
Exit Function
End If
intPos = 1
Do
intPos = InStr(intPos, ScanString, ".")
If intPos = 0 Then
Exit Do
Else
intPos = intPos + 1
intPosSave = intPos - 1
End If
Loop
GetExtName = Trim$(Mid$(ScanString, intPosSave + 1))
End Function
Sub SaveXML1()
Dim i As Integer
Dim strFile As String
i = 1
Dim OL As Outlook.Application
Dim Msg As Outlook.MailItem
Set OL = New Outlook.Application
strFile = Dir$("C:\ATT\" & "*.MSG")
Do While strFile <> vbNullString
Set Msg = OL.CreateItemFromTemplate("C:\ATT\" & strFile)
'for all attachments do...
For Each at In Msg.Attachments
at.SaveAsFile "C:\ATT\MSG\" & Replace(at.FileName, "." & GetExtName(at.FileName), "") & "-" & CStr(i) & "." & GetExtName(at.FileName)
i = i + 1
Next at
Set Msg = Nothing
strFile = Dir
Loop
Set OL = Nothing
SaveXML12
End Sub
Function SaveXML12()
Dim i As Integer
Dim strFile As String
i = 21
Dim OL As Outlook.Application
Dim Msg As Outlook.MailItem
Set OL = New Outlook.Application
strFile = Dir$("C:\ATT\MSG\" & "*.MSG")
Do While strFile <> vbNullString
Set Msg = OL.CreateItemFromTemplate("C:\ATT\MSG\" & strFile)
'for all attachments do...
For Each at In Msg.Attachments
at.SaveAsFile "C:\ATT\MSG\" & Replace(at.FileName, GetExtName(at.FileName), "") & "-" & CStr(i) & "." & GetExtName(at.FileName)
i = i + 1
Next at
Set Msg = Nothing
strFile = Dir
Loop
Set OL = Nothing
End Function
Sub ExportToExcel()
On Error Resume Next
Kill "C:\ATT\MSG\*.*"
Kill "C:\ATT\*.*"
On Error GoTo 0
On Error GoTo ErrHandler
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim Msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
strSheet = "List.xls"
strPath = "C:\ATT\"
strSheet = strPath & strSheet
Debug.Print strSheet
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If
'Open and activate Excel workbook.
Dim i As Integer
i = 0
For Each itm In fld.Items
For Each Atmt In itm.Attachments
If (GetExtName(Atmt.FileName) = "msg") Then
FileName = "C:\ATT\" & Replace(Atmt.FileName, "." & GetExtName(Atmt.FileName), "") & "-" & CStr(i) & "." & GetExtName(Atmt.FileName)
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next itm
SaveXML1
ReadXML
Set Msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler: If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
Else
MsgBox Err.Number & "; Description: ", vbOKOnly, _
"Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set Msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub
Function ReadXML()
Dim xml_doc As New DOMDocument
Dim oRoot As MSXML2.IXMLDOMNode
Dim nde_test As IXMLDOMElement
Dim nde_test2 As IXMLDOMElement
Dim oAttributes As MSXML2.IXMLDOMNamedNodeMap
Dim oChildren As MSXML2.IXMLDOMNodeList
Dim strFile As String
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
strSheet = "List.xls"
strPath = "C:\"
intColumnCounter = 1
intRowCounter = 1
strSheet = strPath & strSheet
Dim i As Integer
Dim OL As Outlook.Application
Dim Msg As Outlook.MailItem
Set OL = New Outlook.Application
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
strFile = Dir$("C:\ATT\MSG\" & "*.xml")
Do While strFile <> vbNullString
intColumnCounter = 1
intRowCounter = intRowCounter + 1
xml_doc.Load "C:\att\msg\" & strFile
Dim nNodeList As MSXML2.IXMLDOMNodeList
Dim nNode As MSXML2.IXMLDOMNode
Set oRoot = xml_doc.DocumentElement
Set rng = wks.Cells(1, 1)
rng.Value = "Provider"
Set rng = wks.Cells(1, 2)
rng.Value = "SONumber"
Set rng = wks.Cells(1, 3)
rng.Value = "Receiptdate"
Set rng = wks.Cells(1, 4)
rng.Value = "Receipthr"
Set rng = wks.Cells(1, 5)
rng.Value = "NumberOfCartons"
Set rng = wks.Cells(1, 6)
rng.Value = "Weight"
Set rng = wks.Cells(1, 7)
rng.Value = "Volume"
For Each nNode In oRoot.ChildNodes
For Each lnode In nNode.ChildNodes
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = lnode.Text
intColumnCounter = intColumnCounter + 1
Next lnode
Next nNode
strFile = Dir
Loop
Set OL = Nothing
End Function
No comments:
Post a Comment