Outlook 256 character limit when saving

[johnjames127]

We have a macro that allows us to save any received emails in certain folders on our network, which works well. When we receive an email message we double click on it the macro opens and we select a location to save it (a bit like windows explorer). The macro saves the email with the date when received, who it is from, subject and a .html or .txt extension.

strpath = FolderPath & strDateReceived & " " & strFrom & "; " & strEmailSubject & strExt

The problem is if the save location and file name exceed 256 characters the .html or .txt extension is not saved It only saves up to character number 256. So the email is just saved as a file which will not open and is not searchable, but if you manually rename it and place a extension the file opens no problem in windows.

I have a basic understanding of vba structure but not much coding experience, could an If statement be added somewhere in the code to check the number of characters before saving?

Cheers

 

[misterstick]

strpath = FolderPath & strDateReceived & " " & strFrom & "; " & strEmailSubject
if len(strPath) > 251 then
 strpath = left(strpath, 251)
endif
strpath = strpath & strExt

mr s. <

 

[PHV]

A simpler way:
strpath = Left(FolderPath & strDateReceived & " " & strFrom & "; " & strEmailSubject, 251) & strExt

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[johnjames127]

Thanks for the help guys but I still having problems and cant figure out whats wrong I've inserted the line of code from PHV the email save OK but the macro ends with a debug error message. I cant figure out way, Have I got the line in he right place?

Private Sub Save_Click()

    Dim myolapp As Outlook.Application
    Dim myinspector As Outlook.Inspector
    Dim newItem As Outlook.MailItem
    Dim MaPI As NameSpace
    Dim myNamespace As NameSpace
    Dim myfolder As MAPIFolder
    Dim FolderPath As String
    
    Dim olobject As Inspector
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    Set olobject = Inspectors.Item(1)
    Set objfrmmail = olobject.CurrentItem
    
    Dim strpath, strDateReceived, strEmailSubject, strCustomerName, strJobNo, strBody, strTo, strCC As String
    Dim strSentOn As String
    
    strDateReceived = Replace(Replace(CStr(objfrmmail.ReceivedTime), "/", "-"), ":", "-")
    
    strEmailSubject = objfrmmail.Subject
    strEmailSubject = Replace(Replace(strEmailSubject, """", ""), "*", "")
    strEmailSubject = Replace(Replace(strEmailSubject, "<", ""), ">", "")
    strEmailSubject = Replace(Replace(strEmailSubject, "\", ""), "/", "")
    strEmailSubject = Replace(Replace(strEmailSubject, ":", ""), "?", "")
    
    strFrom = objfrmmail.SenderName
    
    If strFrom = "" Then
        Set MaPI = GetNamespace("MAPI")
        strFrom = MaPI.CurrentUser
    End If

     strTo = objfrmmail.To
     strCC = objfrmmail.CC
     strBody = objfrmmail.Body
     strBodyFormat = objfrmmail.BodyFormat
     
     If strBodyFormat = 1 Then
      strExt = ".txt"
     Else
      strExt = ".HTML"
     End If
     
    FolderPath = Path.Caption
    
'[COLOR=red]PHV Line of code
    strpath = Left(FolderPath & strDateReceived & " " & strFrom & "; " & strEmailSubject, 251) & strExt

Old line of code
    'strpath = FolderPath & strDateReceived & " " & strFrom & "; " & strEmailSubject & strExt [/color]
    
    MsgBox (strpath)
    
    msgstrpath = "\\ServerQG\Data\General E-Mail\" & strDateReceived & " " & strFrom & "; " & strEmailSubject & ".msg"


    If objFSO.FileExists(strpath) = True Then
        MsgBox "This email has already been saved in this folder", vbOKOnly
    Else
    
   On Error GoTo ErrTestFolder
    
        Set testfolder = objFSO.GetFolder(FolderPath)
        
        Set txtSO = testfolder.CreateTextFile("testfile.txt", True, False)
        txtSO.WriteLine ("a new text file")
        txtSO.Close

        Set txtSO = Nothing
        
        Set txtSO = objFSO.GetFile(FolderPath & "testfile.txt")
        txtSO.Delete
        
        Set txtSO = Nothing
        Set testfolder = Nothing
        Set objFSO = Nothing
    
       On Error GoTo ErrHandler
       
        If strBodyFormat = 1 Then
         '   MsgBox "plain"
           ' Set myolapp = CreateObject("Outlook.Application")
            'Set myNamespace = myolapp.GetNamespace("MAPI")
            'Set myfolder = myNamespace.GetDefaultFolder(olFolderInbox)
            'Set newItem = myfolder.Items.Add(olMailItem)
            'newItem.Subject = strEmailSubject
            'newItem.To = strTo
            'newItem.CC = strCC
            'newItem.SentOnBehalfOfName = strFrom
            'newItem.BodyFormat = olFormatHTML
            'newItem.Body = strBody
            'newItem.SaveAs strpath, olHTML
            objfrmmail.SaveAs strpath, olPlain
        Else
            objfrmmail.SaveAs strpath, olHTML
        End If
       
        objfrmmail.SaveAs msgstrpath
        
    End If

    userfrmsaveemail.Hide
    
    Set objfrmmail = Nothing
    Set myinspector = Nothing
    Set olobject = Nothing
Exit Sub

ErrTestFolder:
        MsgBox "You do not have permission to use this folder.  Please try again."
  
        Exit Sub
        
Resume Next
    
ErrHandler:
   MsgBox "An Error has occurred please contact Nitec with details of the email.  Please click 'Yes' on the following security check "
   
    Set myolapp = CreateObject("Outlook.Application")
    Set myNamespace = myolapp.GetNamespace("MAPI")
    Set myfolder = myNamespace.GetDefaultFolder(olFolderInbox)
    Set newItem = myfolder.Items.Add(olMailItem)
    newItem.Subject = strEmailSubject
    newItem.To = "me@myaddress.com"
    newItem.Body = msgstrpath & "   " & strpath

'[COLOR=red] This is were the debug error points to

    newItem.Send

  [/color]  
Resume Next

  userfrmsaveemail.Hide
  
    
End Sub

 

[johnjames127]

Thanks for the help. I seemed to have got it sorted I also added the code to the .msg line and that seemed to have fix it.


Thanks again