Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- On Error Resume Next
- Dim myNameSpace
- Dim ofChosenFolder
- Dim myOlApp
- Dim myItem
- Dim objItem
- Dim myFolder
- Dim strSubject
- Dim strName
- Dim strFile
- Dim strReceived
- Dim strSavePath
- Set objFSO = CreateObject("Scripting.FileSystemObject")
- Set myOlApp = CreateObject("Outlook.Application")
- Set myNameSpace = myOlApp.GetNamespace("MAPI")
- Set ofChosenFolder = myNameSpace.PickFolder
- 'get path to My Docs
- Dim szDocsFolder, g_shell
- Set g_shell = CreateObject("WScript.Shell")
- szTempFolder = g_shell.SpecialFolders("MyDocuments")
- 'Get the current Username
- Set WshNetwork = WScript.CreateObject("WScript.Network")
- strUser = WshNetwork.UserName
- 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 & "\")
- If not right(strSavePath,1) = "\" then
- strSavePath = strSavePath & "\"
- wscript.echo "You forgot a backslash at the end of your path." & vbcrlf & "But don't worry, I added one for you."
- End If
- ' strSavePath = strSavePath & ofChosenFolder & "\"
- strSaveFolder = Left(strSavePath, Len(strSavePath)-1)
- If Not objFSO.FolderExists(strSaveFolder) then
- if MsgBox("The folder you specified does not exist." & vbcrlf & "Would you like one created?", VBYesNo, "Folder Not Found") = 7 then
- wscript.echo "Exiting script. Try again."
- Else
- objFSO.CreateFolder(strSaveFolder)
- wscript.echo strSaveFolder & " - Created"
- End if
- End if
- i = 1
- For each Item in ofChosenFolder.Items
- Set myItem = ofChosenFolder.Items(i)
- strReceived = ArrangedDate(myitem.ReceivedTime)
- ' strSubject = myItem.Subject
- strSubject = myitem.SenderName & "_" & myitem.Subject
- strName = StripIllegalChar(strSubject)
- strFile = strSavePath & strReceived & "_" & strName & ".msg"
- If Not Len(strfile) > 256 then
- myItem.SaveAs strfile, 3
- Else
- wscript.echo strfile & vbcrlf & "Path and filename too long."
- End If
- i = i + 1
- next
- Function StripIllegalChar(strInput)
- '***************************************************
- 'Simple function that removes illegal file system
- 'characters.
- '***************************************************
- Set RegX = New RegExp
- RegX.pattern = "[\" & chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\`\'\;\:\<\>\?\/\,]"
- RegX.IgnoreCase = True
- RegX.Global = True
- StripIllegalChar = RegX.Replace(strInput, "")
- Set RegX = nothing
- End Function
- Function ArrangedDate(strDateInput)
- '***************************************************
- 'This function re-arranges the date data in order
- 'for it to display in chronilogical order in a
- 'sorted list in the file system. It also removes
- 'illegal file system characters and replaces them
- 'with dashes.
- 'Example:
- 'Input: 2/26/2004 7:07:33 AM
- 'Output: 2004-02-26_AM-07-07-33
- '***************************************************
- Dim strFullDate
- Dim strFullTime
- Dim strAMPM
- Dim strTime
- Dim strYear
- Dim strMonthDay
- Dim strMonth
- Dim strDay
- Dim strDate
- Dim strDateTime
- Dim RegX
- If not Left(strDateInput, 2) = "10" Then
- If not Left(strDateInput, 2) = "11" Then
- If not Left(strDateInput, 2) = "12" Then
- strDateInput = "0" & strDateInput
- End If
- End If
- End If
- strFullDate = Left(strDateInput, 10)
- If Right(strFullDate, 1) = " " Then
- strFullDate = Left(strDateInput, 9)
- End If
- strFullTime = Replace(strDateInput,strFullDate & " ","")
- If Len(strFullTime) = 10 Then
- strFullTime = "0" & strFullTime
- End If
- strAMPM = Right(strFullTime, 2)
- strTime = strAMPM & "-" & Left(strFullTime, 8)
- strYear = Right(strFullDate,4)
- strMonthDay = Replace(strFullDate,"/" & strYear,"")
- strMonth = Left(strMonthDay, 2)
- strDay = Right(strMonthDay,len(strMonthDay)-3)
- If len(strDay) = 1 Then
- strDay = "0" & strDay
- End If
- strDate = strYear & "-" & strMonth & "-" & strDay
- 'strDateTime = strDate & "_" & strTime
- strDateTime = strDate
- Set RegX = New RegExp
- RegX.pattern = "[\:\/\ ]"
- RegX.IgnoreCase = True
- RegX.Global = True
- ArrangedDate = RegX.Replace(strDateTime, "-")
- Set RegX = nothing
- End Function
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement