dvsaver vbs

dvsaver.vbs

Public Sub saveAttachtoDisk()
Dim itm As Outlook.MailItem
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim strSubject As String, strExt As String
Dim objAtt As Outlook.Attachment
Dim saveFolder As String

Dim enviro As String
' enviro = CStr(Environ("\\Corp.ngsmedicare.com\Users"))
saveFolder = "L:\SDC - DataVault\Daily Data Vault pickup delivery sheets\2019 DV Sheets\"

Set currentExplorer = Application.ActiveExplorer
Set Selection = currentExplorer.Selection

For Each itm In Selection
 For Each objAtt In itm.Attachments
' get the last 5 characters for the file extension
strExt = Right(objAtt.DisplayName, 4)
' clean the subject
strSubject = itm.Subject
ReplaceCharsForFileName strSubject, "-"

' put the name and extension together
file = saveFolder & "DV " & Format(Date, "mmddyyyy") & strExt
 
 objAtt.SaveAsFile file
 Next
Next
 
 Set objAtt = Nothing
 End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub