Saving Send emails to a folder on the server

[Diane Poremsky]

It's working here - but it is saved as an unsent message. If you want to save it after it was sent, you need to use the itemadd macro - after adding it to thisoutlooksession, click in application startup and click run to kick start it.

Private WithEvents objSentItems As Items

Private Sub Application_Startup()
Dim objSent As Outlook.MAPIFolder
Set objNS = Application.GetNamespace("MAPI")
Set objSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
Set objNS = Nothing
End Sub
 
Private Sub objSentItems_ItemAdd(ByVal oMail As Object)

 Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim StrFolderpath As String
  Dim StrUserPath As Variant

'Defaults to Documents folder
'get the function at http://slipstick.me/u1a2d
If oMail.MessageClass = "IPM.Note" Then

StrUserPath = "C:\Users\JennyWren\OneDrive - Slipstick Systems\Documents\"
StrFolderpath = BrowseForFolder(StrUserPath)

If StrFolderpath = "False" Then
      Cancel = True
      Exit Sub
  End If
 
  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"
 
  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "ddmmyyyy", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
     
  sPath = StrFolderpath & "\"
  Debug.Print sPath & sName
  oMail.SaveAs sPath & sName, olMSG
 
  End If
 
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

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
  Dim ShellApp As Object
  Set ShellApp = CreateObject("Shell.Application"). _
 BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
 
 On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
 On Error GoTo 0
 
 Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
 Exit Function
 
Invalid:
    BrowseForFolder = False
End Function

 

[JohanKotze]

Hi Diane
I set up Outlook in Startup but and it saved the email after sending. Thx very much for this but,
1. My outlook is always on so I can't kick start it. I never shut it down as I work remotely from time to time and need to RDP to my PC
2. I need the headers of the send email all so to be saved.

 

[Diane Poremsky]

1. It should always run once started - if it errors, it will need restarted.

I add this macro to a button to kick start it when I think it might not be working-

Sub RunStart()
 Call Application_Startup
 MsgBox "App Start Started"
End Sub

2. As in the internet headers? They should be on the message. Open it then File > Properties.

 

[JohanKotze]

1. It should always run once started - if it errors, it will need restarted.

I add this macro to a button to kick start it when I think it might not be working-

Sub RunStart()
 Call Application_Startup
 MsgBox "App Start Started"
End Sub

2. As in the internet headers? They should be on the message. Open it then File > Properties.

Thx Diane

 

[JohanKotze]

1. It should always run once started - if it errors, it will need restarted.

I add this macro to a button to kick start it when I think it might not be working-

Sub RunStart()
 Call Application_Startup
 MsgBox "App Start Started"
End Sub

2. As in the internet headers? They should be on the message. Open it then File > Properties.

Hi Diane where did you put your kick start button?

 

[JohanKotze]

Hi Diane where did you put your kick start button?

Hi Diane where did you put your kick start button?

Hi Diane
This just happened to me, selecting the wrong dir, CommercialClients instead of PersonalClients. The popup dialog file tree
Clients
>CommercialClients
>PersonalClients

So I click on Clients again thinking that it will bring me back to file tree above but can't
Is there away to accomplish this

 

[JohanKotze]

Hi Diane
I copied the code to my admin PC. Digital Signed the code. Marco settings is set to Digitally Signed macros, disabled all others and saved the project.

When I went back into Outlook I get a message that Macros are disabled. The Digital Signature is still active under vba editor/digital signature. Does have perhaps to do with references?

 

[JohanKotze]

Hi Diane after my fiddling. I have a look at Coms.Add Ins, Disabled Items. Both PCs setup are the same. Only difference is that the Admin PC has Office 2019 on it as mine has 2021.

On the Admin PC the Digital Certificate is accepted. Reason knowing that is when I select the Certificate Remove and reselect it, save all and restart Outook 2019 message box pop up asking if trust the Certificate on which I click yes.

Then I send and email but no popup dialog as on on my Outlook 2021

Clients
>ComercialClients
>PersonalClients

I run debug but no errors in immediate window.

All is precisely Setup as on my Outlook 2021.
Can this be a setting that I miss.

 

[JohanKotze]

Might this be the problem for dialog box not showing?
Microsoft Windows common controls?

 

[Diane Poremsky]

Hi Diane
This just happened to me, selecting the wrong dir, CommercialClients instead of PersonalClients. The popup dialog file tree
Clients
>CommercialClients
>PersonalClients

So I click on Clients again thinking that it will bring me back to file tree above but can't
Is there away to accomplish this

You are still in the folder picker dialog? It's working as expected here - I can select a folder and then choose a different folder.

 

[JohanKotze]

You are still in the folder picker dialog? It's working as expected here - I can select a folder and then choose a different folder.

Diane
I can't see the folder picker dialog. If it's there then it might be in the back ground or something but it's not visible. I minimize all the open programs but still no folder picker. Maybe a setting in Outlook about popups?
This is Outlook 2019 with Windows 10 Pro

 

[Diane Poremsky]

No, its not a setting. Add
msgbox "macro is running"

after the dim statements so we know if its running.

 

[JohanKotze]

Diane I this

Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim StrFolderpath As String
Dim StrUserPath As Variant

Msgbox "macro is running"

 

[JohanKotze]

Diane Iike this

Dim sPath As String
Dim dtDate As Date
Dim sName As String
Dim StrFolderpath As String
Dim StrUserPath As Variant

Msgbox "macro is running"

Hi Diane
Macro is not running.
I do not understand as this setup is exactly the same as the other to PCs

 

[JohanKotze]

Hi Diane
Macro is not running.
I do not understand as this setup is exactly the same as the other to PCs

I found the below as a disabled item on my other pc but not on this one where I struggle to get the code running.

Hi Diane
Macro is not running.
I do not understand as this setup is exactly the same as the other to PCs

I found on my pc where the code is running perfectly in Outlook that this item below is disabled but not on the pc in struggle with the vba code to run in Outlook. How do make this an disabled item as on my other pc.

 

[JohanKotze]

I found this under disabled add ins items in Outlook 2021 that run the VBA code

As I can't find nothing under Disabled Add Ins items in Outlook 2019 (other PC). Can this prevent the code form running?

And is so how do I add it under Disabled Add Ins items.

 

[JohanKotze]

Hi Diane
I was wondering, appart from that still struggle to get SaveMessage code to work in Outlook 2019. If it is possible, can the popup dialog folder picker be restricted to 1 pc (which I remotely connect to) as I use IMAP email account.

So if I send emails from my android tablet then when I get back to the office there is a few dialog file pickers boxes open. Is there away around this.

 

[JohanKotze]

Ok I run Outlook 2019 in safe mode (Outlook.exe /safe)
I then run Debug to cursor and get the following File Picker Dialog called Capture instead of the Correct Dialog (please see attachments). This happens in safe mode. In normal mode no popup dialog

 

[Diane Poremsky]

I found this under disabled add ins items in Outlook 2021 that run the VBA code

View attachment 4266
As I can't find nothing under Disabled Add Ins items in Outlook 2019 (other PC). Can this prevent the code form running?

And is so how do I add it under Disabled Add Ins items.

I don't know what add-in that one is - but as long as the VB add-in is loaded, the macro will work.

I'm guessing klavplg is part of the parent apps name - maybe stands for klav plugin? Beyond that, I don't know what it is or what klav could be.

 

[Diane Poremsky]

Hi Diane
I was wondering, appart from that still struggle to get SaveMessage code to work in Outlook 2019. If it is possible, can the popup dialog folder picker be restricted to 1 pc (which I remotely connect to) as I use IMAP email account.

So if I send emails from my android tablet then when I get back to the office there is a few dialog file pickers boxes open. Is there away around this.

Ah... its coming up when you sync, because the macro watches for items to be added to the folder. I'll need to think about how to get past that.