outlook email automation

megatronixs

Registered User.
Local time
Today, 21:19
Joined
Aug 17, 2012
Messages
719
Hi all,

I have the below code to save the emails in a folder and insert the email into a database so all users can read the emails from a shared email box without the need to have a huge .pst file that only one person at the time can have open.

All works fine, except a few emails that could be to long or with to much empty spaces.
this is one of the email (after stripping of illegal characters):
20170626-145054_FW Re-Bart tralala Vs dreaming Realisation - 12345678 Eddie Eidde AAA 123456 REC S28 VAL_FEEDBACK.msg

Any clue where it could get wrong?


Code:
Private Sub btn_import_new_emails_Click()
Dim i               As Long
Dim j               As Long
Dim n               As Long
Dim StrSubject      As String
Dim StrName         As String
Dim StrFile         As String
Dim StrReceived     As String
Dim ReceivedTime As String
Dim StrFolder       As String
Dim StrSaveFolder   As String
Dim StrFolderPath   As String
Dim iNameSpace      As Outlook.NameSpace
Dim myOlApp         As Outlook.Application
Dim SubFolder       As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim mItem           As Outlook.MailItem
Dim oMailLink       As Outlook.MailItem
Dim FSO             As Object
Dim ChosenFolder    As Object
Dim Folders         As New Collection
Dim EntryID         As New Collection
Dim StoreID         As New Collection
Dim acAppdB As DAO.Database
Dim rs As DAO.Recordset
Dim strSQL As String
Dim iTemClass As String
Dim olApp As Outlook.Application
Dim olFolder As Outlook.MAPIFolder
Dim InboxItem As Object
Set myOlApp = Outlook.Application
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myOlApp = Outlook.Application
Set iNameSpace = myOlApp.GetNamespace("MAPI")
Set ChosenFolder = iNameSpace.PickFolder
If ChosenFolder Is Nothing Then
GoTo ExitSub:
End If
  
BrowseForFolder StrSavePath 'this have to be changed to default path
 
    Call GetFolder(Folders, EntryID, StoreID, ChosenFolder)
    For i = 1 To Folders.Count
 
        StrFolder = StripIllegalChar(Folders(i))
 
        n = InStr(3, StrFolder, "\") + 1
 
        StrFolder = Mid(StrFolder, n, 256)
 
        StrFolderPath = StrSavePath & "\"
 
        StrSaveFolder = Left(StrFolderPath, Len(StrFolderPath) - 1) & "\"
 
        If Not FSO.FolderExists(StrFolderPath) Then
 
 Debug.Print StrFolderPath
            FSO.CreateFolder (StrFolderPath)
 
        End If
        Set SubFolder = myOlApp.Session.GetFolderFromID(EntryID(i), StoreID(i))
 
        'On Error Resume Next
 
        Set acAppdB = DBEngine(0).OpenDatabase("C:\Outlook_Emails_be.mdb")
 
        For j = 1 To SubFolder.Items.Count
 
            Set mItem = SubFolder.Items(j)
 Debug.Print SubFolder
           
            iTemClass = mItem.Class
                Select Case iTemClass
                    Case "43"
                    strSQL = "SELECT * FROM [tbl_eMail_Archive] WHERE [tbl_eMail_Archive].EntryID = '" & mItem.EntryID & "'"
                    Set rs = acAppdB.OpenRecordset(strSQL)
                        With rs
 
                        If .RecordCount = 0 Then
 
                       .AddNew
 
                                !SenderName = mItem.SenderName  'From whom the email comes from
 
                                !SentON = mItem.SentON
 
                                !SenderName = mItem.SenderName
                                
                                !FolderName = SubFolder
 
                                !To = mItem.To
 
                                !CC = mItem.CC
 
                                !ReceivedTime = mItem.ReceivedTime
 
                                !Subject = mItem.Subject
 
                                !Body = mItem.Body
                                StrReceived = Format(mItem.ReceivedTime, "YYYYMMDD-hhmmss")
 
                                StrSubject = mItem.Subject
 
                                StrName = StripIllegalChar(StrSubject)
 
                                StrFile = StrSaveFolder & StrReceived & "_" & StrName & ".msg"
                                Debug.Print StrFile
 
                                mItem.SaveAs StrFile, 3
                                 !MailLink = StrFile
 
                           .Update
 
                           End If
 
                       End With
 
                    End Select
 
    Next j
 
        On Error GoTo 0
 
    Next i
 
ExitSub:
 
End Sub
 
 Function StripIllegalChar(StrInput)
 
    Dim RegX            As Object
 
    Set RegX = CreateObject("vbscript.regexp")
 
    RegX.Pattern = "[\" & Chr(34) & "\!\@\#\$\%\^\&\*\(\)\=\+\|\[\]\{\}\" & Chr(147) & "\'\;\:\<\>\?\/\,]"
 
    RegX.IgnoreCase = True
 
    RegX.Global = True
 
StripIllegalChar = RegX.Replace(StrInput, "")
 
ExitFunction:
 
    Set RegX = Nothing
 
End Function
 
 'the path is passed here where the emails will be taken from
 
Sub GetFolder(Folders As Collection, EntryID As Collection, StoreID As Collection, fld As MAPIFolder)
 
    Dim SubFolder       As MAPIFolder
 
    Folders.Add fld.FolderPath      'path of the folder in outlook that will be used to get the emails.
 
    EntryID.Add fld.EntryID
 
    StoreID.Add fld.StoreID
 
    For Each SubFolder In fld.Folders
 
        GetFolder Folders, EntryID, StoreID, SubFolder
 
    Next SubFolder  'this gets the name of the current folder the macro is in
 
ExitSub:
 
    Set SubFolder = Nothing
 End Sub
 
'this is where the folder to save is choosen
Function BrowseForFolder(StrSavePath As String, Optional OpenAt As String) As String
 
    Dim objShell As Object
 
    Dim objFolder
 
Dim enviro
 
enviro = CStr(Environ("USERPROFILE"))
 
Set objShell = CreateObject("Shell.Application")
StrSavePath = "C:\Emails"
 
    On Error Resume Next
 
    On Error GoTo 0
 
ExitFunction:
 
    Set objShell = Nothing
End Function
 
There's also some useful API code here https://gist.github.com/knjname/ba3b7d433655d5930a08#file-vbashortpathlongpathconversion-bas

which I have converted to a function for my own purposes (see code below). The provides a function GetShortName(sFile As String) to convert a long path to a short 8.3 alias (example in the commented code).

Code:
Option Compare Database
Option Explicit

Public Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" _
    (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
__________________________________________________________      

Public Function GetShortName(sFile As String) As String

'This converts a long folder pathname to the shorter (DOS) pathname - for example:-
'C:\Users\bemer\OneDrive\Documents\Databases\DC_Database\14554\Docs\STOR\ME
'becomes
'C:\Users\bemer\OneDrive\DOCUME~1\DATABA~1\DC_DAT~1\14554\Docs\STOR\ME
'Particularly useful if there is a limit to the filepath length, or no spaces are allowed etc

    Dim sShortFile As String * 255
    Dim lResult As Long

    'Make a call to the GetShortPathName API
    lResult = GetShortPathName(sFile, sShortFile, Len(sShortFile))

    'Trim out unused characters from the string.
    GetShortName = Left$(sShortFile, lResult)

End Function
 

Users who are viewing this thread

Back
Top Bottom