daily pastebin goal
26%
SHARE
TWEET

Untitled

a guest Feb 11th, 2019 54 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Public xFlag As Boolean
  2. Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
  3. Dim objSent As Outlook.MAPIFolder
  4. Dim oMail As Outlook.mailItem
  5. Dim prompt As String
  6. Dim sPath As String
  7. Dim dtDate As Date
  8. Dim sName As String
  9. Dim enviro As String
  10. Dim emailto As String
  11.  
  12. Dim MsgColl As Object
  13. Dim msg As Outlook.mailItem
  14. Dim objNS As Outlook.NameSpace
  15. Dim i As Long
  16. Dim subjectname As String
  17.  
  18.  
  19.  
  20. Set objNS = Application.GetNamespace("MAPI")
  21. Set objSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
  22. Set objNS = Nothing
  23.  
  24. prompt = "Are you sure you want to send " & Item.Subject & "?"
  25. If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then
  26. Cancel = True
  27. End If
  28.  
  29. enviro = CStr(Environ("USERPROFILE"))
  30. Original = Item.Subject
  31. sName = Item.Subject
  32. 'MsgBox sName
  33. 'ReplaceCharsForFileName sName, "-"
  34.  
  35.  dtDate = Item.ReceivedTime
  36.  
  37.  emailto = Item
  38.  
  39.  
  40.  
  41.  
  42.  sName = Format(dtDate, "yyyy-mm-dd", vbUseSystemDayOfWeek, _
  43. vbUseSystem) & " (Out) '" & sName & "' " & Format(dtDate, " (hh-nn-ss)", _
  44. vbUseSystemDayOfWeek, vbUseSystem) & " (" & emailto & ").msg"
  45.  
  46. 'MsgBox sName
  47.  
  48.  
  49.  
  50. sPath = "d:efilecabinet-email"
  51.  
  52. On Error Resume Next
  53. Select Case TypeName(Application.ActiveWindow)
  54. Case "Explorer"
  55.          ' a collection of selected items
  56.         Set MsgColl = ActiveExplorer.Selection
  57.     Case "Inspector"
  58.          ' only one item was selected
  59.         Set msg = ActiveInspector.CurrentItem
  60. End Select
  61. On Error GoTo 0
  62.  
  63. If (MsgColl Is Nothing) And (msg Is Nothing) Then
  64.     GoTo ExitProc
  65. End If
  66.  
  67.  
  68. If Not MsgColl Is Nothing Then
  69.     For i = 1 To MsgColl.Count
  70.          ' set an obj reference to each mail item so we can move it
  71.         Set msg = MsgColl.Item(i)
  72.         With msg
  73.             .Subject = sName & " (Efiled)"
  74.             .Save
  75.         End With
  76.     Next i
  77. ElseIf Not msg Is Nothing Then
  78.     msg.Subject = sName & " (Efiled)"
  79. End If
  80.  
  81. ExitProc:
  82.  
  83. Set msg = Nothing
  84. Set MsgColl = Nothing
  85. 'Set olMyFldr = Nothing
  86. Set objNS = Nothing
  87.  
  88. 'Set oSel = Application.ActiveExplorer.Selection
  89. 'For Each oMail In oSel
  90. 'Item.Categories = "Bookkeeping"
  91. 'Item.Save
  92.  
  93. Debug.Print sPath & sName
  94. Item.SaveAs sPath & sName, olMSG
  95.  
  96. 'MsgBox Original
  97.  
  98.  
  99. Item.Subject = Original & " (Efiled)"
  100. End Sub
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top