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?
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