Pastebin launched a little side project called HostCabi.net, check it out ;-)Don't like ads? PRO users don't see any ads ;-)
Guest

Export Outlook Emails as MSGs

By: melanieLH on Mar 14th, 2013  |  syntax: None  |  size: 4.07 KB  |  hits: 2,845  |  expires: Never
download  |  raw  |  embed  |  report abuse  |  print
Text below is selected. Please press Ctrl+C to copy to your clipboard. (⌘+C on Mac)
  1.  On Error Resume Next
  2. Dim myNameSpace
  3. Dim ofChosenFolder
  4. Dim myOlApp
  5. Dim myItem
  6. Dim objItem
  7. Dim myFolder
  8. Dim strSubject
  9. Dim strName
  10. Dim strFile
  11. Dim strReceived
  12. Dim strSavePath
  13.  
  14. Set objFSO = CreateObject("Scripting.FileSystemObject")
  15. Set myOlApp = CreateObject("Outlook.Application")
  16. Set myNameSpace = myOlApp.GetNamespace("MAPI")
  17. Set ofChosenFolder = myNameSpace.PickFolder
  18.  
  19.  
  20. 'get path to My Docs
  21. Dim szDocsFolder, g_shell
  22. Set g_shell = CreateObject("WScript.Shell")
  23. szTempFolder = g_shell.SpecialFolders("MyDocuments")
  24.  
  25. 'Get the current Username
  26. Set WshNetwork = WScript.CreateObject("WScript.Network")
  27. strUser = WshNetwork.UserName
  28.  
  29. strSavePath = InputBox("Please enter the path to save to and be sure to end with a backslash at the end of your path. You can enter a new folder name if you like and it will be created", "Save Emails To:", szTempFolder & "\Saved Emails\" & ofChosenFolder & "\")
  30.  
  31. If not right(strSavePath,1) = "\" then
  32. strSavePath = strSavePath & "\"
  33. wscript.echo "You forgot a backslash at the end of your path." & vbcrlf & "But don't worry, I added one for you."
  34. End If
  35.  
  36. ' strSavePath = strSavePath & ofChosenFolder & "\"
  37.  
  38. strSaveFolder = Left(strSavePath, Len(strSavePath)-1)
  39.  
  40. If Not objFSO.FolderExists(strSaveFolder) then
  41. if MsgBox("The folder you specified does not exist." & vbcrlf & "Would you like one created?", VBYesNo, "Folder Not Found") = 7 then
  42. wscript.echo "Exiting script. Try again."
  43. Else
  44. objFSO.CreateFolder(strSaveFolder)
  45. wscript.echo strSaveFolder & " - Created"
  46. End if
  47. End if
  48.  
  49.  
  50. i = 1
  51. For each Item in ofChosenFolder.Items
  52. Set myItem = ofChosenFolder.Items(i)
  53. strReceived = ArrangedDate(myitem.ReceivedTime)
  54. ' strSubject = myItem.Subject
  55. strSubject = myitem.SenderName & "_" & myitem.Subject
  56. strName = StripIllegalChar(strSubject)
  57. strFile = strSavePath & strReceived & "_" & strName & ".msg"
  58. If Not Len(strfile) > 256 then
  59. myItem.SaveAs strfile, 3
  60. Else
  61. wscript.echo strfile & vbcrlf & "Path and filename too long."
  62. End If
  63. i = i + 1
  64. next
  65.  
  66.  
  67.  
  68. Function StripIllegalChar(strInput)
  69.  
  70. '***************************************************
  71. 'Simple function that removes illegal file system
  72. 'characters.
  73. '***************************************************
  74.  
  75. Set RegX = New RegExp
  76.  
  77. RegX.pattern = "[\" & chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
  78. RegX.IgnoreCase = True
  79. RegX.Global = True
  80.  
  81. StripIllegalChar = RegX.Replace(strInput, "")
  82. Set RegX = nothing
  83.  
  84. End Function
  85.  
  86.  
  87. Function ArrangedDate(strDateInput)
  88.  
  89. '***************************************************
  90. 'This function re-arranges the date data in order
  91. 'for it to display in chronilogical order in a
  92. 'sorted list in the file system. It also removes
  93. 'illegal file system characters and replaces them
  94. 'with dashes.
  95. 'Example:
  96. 'Input: 2/26/2004 7:07:33 AM
  97. 'Output: 2004-02-26_AM-07-07-33
  98. '***************************************************
  99.  
  100. Dim strFullDate
  101. Dim strFullTime
  102. Dim strAMPM
  103. Dim strTime
  104. Dim strYear
  105. Dim strMonthDay
  106. Dim strMonth
  107. Dim strDay
  108. Dim strDate
  109. Dim strDateTime
  110. Dim RegX
  111.  
  112. If not Left(strDateInput, 2) = "10" Then
  113. If not Left(strDateInput, 2) = "11" Then
  114. If not Left(strDateInput, 2) = "12" Then
  115. strDateInput = "0" & strDateInput
  116. End If
  117. End If
  118. End If
  119.  
  120. strFullDate = Left(strDateInput, 10)
  121.  
  122. If Right(strFullDate, 1) = " " Then
  123. strFullDate = Left(strDateInput, 9)
  124. End If
  125.  
  126. strFullTime = Replace(strDateInput,strFullDate & " ","")
  127.  
  128. If Len(strFullTime) = 10 Then
  129. strFullTime = "0" & strFullTime
  130. End If
  131.  
  132. strAMPM = Right(strFullTime, 2)
  133.  
  134. strTime = strAMPM & "-" & Left(strFullTime, 8)
  135.  
  136. strYear = Right(strFullDate,4)
  137.  
  138. strMonthDay = Replace(strFullDate,"/" & strYear,"")
  139.  
  140. strMonth = Left(strMonthDay, 2)
  141.  
  142. strDay = Right(strMonthDay,len(strMonthDay)-3)
  143.  
  144. If len(strDay) = 1 Then
  145. strDay = "0" & strDay
  146. End If
  147.  
  148. strDate = strYear & "-" & strMonth & "-" & strDay
  149.  
  150. 'strDateTime = strDate & "_" & strTime
  151. strDateTime = strDate
  152.  
  153. Set RegX = New RegExp
  154.  
  155. RegX.pattern = "[\:\/\ ]"
  156. RegX.IgnoreCase = True
  157. RegX.Global = True
  158.  
  159. ArrangedDate = RegX.Replace(strDateTime, "-")
  160.  
  161. Set RegX = nothing
  162.  
  163. End Function