extracting outlook (1 Viewer)

The_Doc_Man

Immoderate Moderator
Staff member
Local time
Today, 07:52
Joined
Feb 28, 2001
Messages
27,001
Tera: Your question, "Does the attachment have a path?"

Typically, attachments have a place in the container post-office (.PST) file that is your user data file for Outlook. If this attachment has ANY path at all, it is the path of the .PST file - but it is inside a container that isn't a .ZIP, so you cannot treat it like a zipped file and track it with Windows Explorer that automagically opens a zip folder as though it were an ordinary folder. A .PST file isn't compatible with that.
 

vba_php

Forum Troll
Local time
Today, 07:52
Joined
Oct 6, 2019
Messages
2,884
Typically, attachments have a place in the container post-office (.PST) file that is your user data file for Outlook. If this attachment has ANY path at all, it is the path of the .PST file
and I would assume there would be no way to point to that .pst file path with the VBA language, right richard?
 

Gasman

Enthusiastic Amateur
Local time
Today, 12:52
Joined
Sep 21, 2011
Messages
14,052
Here is the path of a word document attachment in one of my emails?

C:\Users\Paul\AppData\Local\Microsoft\Windows\INetCache\Content.Outlook\WI4TG6IO\E20191120000013408099886.doc
 

vba_php

Forum Troll
Local time
Today, 07:52
Joined
Oct 6, 2019
Messages
2,884
Here is the path of a word document attachment in one of my emails?

C:\Users\Paul\AppData\Local\Microsoft\Windows\INetCache\Content.Outlook\WI4TG6IO\E20191120000013408099886.doc
how did you get that!?
 

Gasman

Enthusiastic Amateur
Local time
Today, 12:52
Joined
Sep 21, 2011
Messages
14,052
Look at the properties of the document?
 

vba_php

Forum Troll
Local time
Today, 07:52
Joined
Oct 6, 2019
Messages
2,884
Look at the properties of the document?
gasman, i'm on outlook 2007 and I see no such thing in the prop dialog. see image.
 

Attachments

  • email message properties.jpg
    email message properties.jpg
    104.5 KB · Views: 91

Gasman

Enthusiastic Amateur
Local time
Today, 12:52
Joined
Sep 21, 2011
Messages
14,052
gasman, i'm on outlook 2007 and I see no such thing in the prop dialog. see image.

I never said the properties of the email.
I said the properties of the 'document'. In my case a word document.?

However I knew they were held in a temporary location somewhere, as i have seen it previously.

A picture attachment in another email is

C:\Users\Paul\AppData\Local\Microsoft\Windows\INet Cache\Content.Outlook\WI4TG6IO\IMG_0048.PNG
 

nlwc

New member
Local time
Today, 05:52
Joined
Nov 25, 2019
Messages
9
Hi VBA_PHP, Gasman, et al



I took your code and worked on it, sorry it has taken so long, I'm still learning.


Okie dokie, this is what i have come up with


Code:
'---------------------------------------------------------------------------------
' The sample scripts are not supported under any Microsoft standard support
' program or service. The sample scripts are provided AS IS without warranty
' of any kind. Microsoft further disclaims all implied warranties including,
' without limitation, any implied warranties of merchantability or of fitness for
' a particular purpose. The entire risk arising out of the use or performance of
' the sample scripts and documentation remains with you. In no event shall
' Microsoft, its authors, or anyone else involved in the creation, production, or
' delivery of the scripts be liable for any damages whatsoever (including,
' without limitation, damages for loss of business profits, business interruption,
' loss of business information, or other pecuniary loss) arising out of the use
' of or inability to use the sample scripts or documentation, even if Microsoft
' has been advised of the possibility of such damages.
'---------------------------------------------------------------------------------

Option Explicit

' *****************
' For Outlook 2010.
' *****************
#If VBA7 Then
    ' The window handle of Outlook.
    Private lHwnd As LongPtr
    
    ' /* API declarations. */
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As LongPtr
    
' *****************************************
' For the previous version of Outlook 2010.
' *****************************************
#Else
    ' The window handle of Outlook.
    Private lHwnd As Long
    
    ' /* API declarations. */
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long
#End If

' The class name of Outlook window.
Private Const olAppCLSN As String = "rctrl_renwnd32"
' Windows desktop - the virtual folder that is the root of the namespace.
Private Const CSIDL_DESKTOP = &H0
' Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
Private Const BIF_RETURNONLYFSDIRS = &H1
' Do not include network folders below the domain level in the dialog box's tree view control.
Private Const BIF_DONTGOBELOWDOMAIN = &H2
' The maximum length for a path is 260 characters.
Private Const MAX_PATH = 260

' ######################################################
'  Returns the number of attachements in the selection.
' ######################################################
Public Function SaveAttachmentsFromSelection() As Long
    Dim objFSO              As Object       ' Computer's file system object.
    Dim objShell            As Object       ' Windows Shell application object.
    Dim objFolder           As Object       ' The selected folder object from Browse for Folder dialog box.
    Dim objItem             As Object       ' A specific member of a Collection object either by position or by key.
    Dim selItems            As Selection    ' A collection of Outlook item objects in a folder.
    Dim atmt                As Attachment   ' A document or link to a document contained in an Outlook item.
    Dim strAtmtPath         As String       ' The full saving path of the attachment.
    Dim strAtmtFullName     As String       ' The full name of an attachment.
    Dim strAtmtName(1)      As String       ' strAtmtName(0): to save the name; strAtmtName(1): to save the file extension. They are separated by dot of an attachment file name.
    Dim strAtmtNameTemp     As String       ' To save a temporary attachment file name.
    Dim intDotPosition      As Integer      ' The dot position in an attachment name.
    Dim atmts               As Attachments  ' A set of Attachment objects that represent the attachments in an Outlook item.
    Dim lCountEachItem      As Long         ' The number of attachments in each Outlook item.
    Dim lCountAllItems      As Long         ' The number of attachments in all Outlook items.
    Dim strFolderPath       As String       ' The selected folder path.
    Dim blnIsEnd            As Boolean      ' End all code execution.
    Dim blnIsSave           As Boolean      ' Consider if it is need to save.
    
    Dim sFileEmail          As String       ' TXT Email data File Name
    Dim sFileAttachment     As String       ' TXT Attachment data File Name
    Dim sFileBodyText           As String       ' TXT For Email body
    Dim sBody               As String       ' Email Body
    Dim i                   As Long
    blnIsEnd = False
    blnIsSave = False
    lCountAllItems = 0
    i = 0
    Set selItems = ActiveExplorer.Selection
    
    If Err.Number = 0 Then
        
        ' Get the handle of Outlook window.
        lHwnd = FindWindow(olAppCLSN, vbNullString)
        
        If lHwnd <> 0 Then
            
            ' /* Create a Shell application object to pop-up BrowseForFolder dialog box. */
            Set objShell = CreateObject("Shell.Application")
            Set objFSO = CreateObject("Scripting.FileSystemObject")
            Set objFolder = objShell.BrowseForFolder(lHwnd, "Select folder to save attachments:", _
                                                     BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)
            
            ' /* Failed to create the Shell application. */
            If Err.Number <> 0 Then
                MsgBox "Run-time error '" & CStr(Err.Number) & " (0x" & CStr(Hex(Err.Number)) & ")':" & vbNewLine & _
                       Err.Description & ".", vbCritical, "Error from Attachment Saver"
                blnIsEnd = True
                GoTo PROC_EXIT
            End If
            
            If objFolder Is Nothing Then
                strFolderPath = ""
                blnIsEnd = True
                GoTo PROC_EXIT
            Else
                strFolderPath = CGPath(objFolder.Self.Path)
                
                sFileEmail = strFolderPath & "PST_Report.txt"
                sFileAttachment = strFolderPath & "ATT_Report.txt"
                sFileBodyText = strFolderPath & "BodyText_Report.txt"
                Open sFileEmail For Output As #1
                
                Print #1, "EntryID,Importance,Subject,From,Sender_Name,CC,To,Received,Message_Size," & _
                "Created,Modified,AttachmentsCount"
                
                Open sFileAttachment For Output As #2
                
                Print #2, "EntryID,Attachment_FileName,Attachment_Location,Attachment_Link"
                
                Open sFileBodyText For Output As #3
                
                Print #3, "EntryID,BodyText"

                ' /* Go through each item in the selection. */
                For Each objItem In selItems
                    i = i + 1
                    
                    On Error Resume Next
                    sBody = Left(F_Body(objItem.Body), 10000)
                    On Error GoTo 0
                    
                    Print #3, objItem.EntryID & "," & """" & sBody & """"
                    
                    
                    On Error Resume Next
                    Print #1, objItem.EntryID & "," & objItem.Importance & "," & """" & objItem.Subject & """" & "," & _
                    objItem.SenderEmailAddress & "," & """" & objItem.SenderName & """" & "," & """" & objItem.CC & """" & _
                    "," & """" & objItem.To & """" & "," & objItem.ReceivedTime & "," & _
                    objItem.Size & "," & objItem.CreationTime & "," & objItem.LastModificationTime & "," & CStr(lCountEachItem)
                    If Err.Number <> 0 Then
                        On Error GoTo 0
                        Print #1, objItem.EntryID & "," & objItem.Importance & "," & """" & objItem.Subject & """"
                        Debug.Print objItem.EntryID & "," & objItem.Importance & "," & """" & objItem.Subject & """" & "Err1"
                    End If
                    On Error GoTo 0
                    On Error Resume Next
                    lCountEachItem = objItem.Attachments.Count
                    If Err.Number <> 0 Then
                        On Error GoTo 0
                        lCountEachItem = 0
                        Debug.Print objItem.EntryID & "," & objItem.Importance & "," & """" & objItem.Subject & """" & "Err2"
                    End If
                    On Error GoTo 0
                    ' /* If the current item contains attachments. */
                    If lCountEachItem > 0 Then
                        Set atmts = objItem.Attachments
                        
                        ' /* Go through each attachment in the current item. */
                        For Each atmt In atmts
                            
                            
                            On Error Resume Next
                            If InStr(1, atmt.FileName, ".") > 0 _
                            And Err.Number = 0 Then
                                Print #2, objItem.EntryID & "," & atmt.FileName & "," & strFolderPath & "," & strFolderPath & atmt.FileName
                                ' Get the full name of the current attachment.
                                strAtmtFullName = atmt.FileName
                                
                                ' Find the dot postion in atmtFullName.
                                intDotPosition = InStrRev(strAtmtFullName, ".")
                                
                                ' Get the name.
                                strAtmtName(0) = Left$(strAtmtFullName, intDotPosition - 1)
                                ' Get the file extension.
                                strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
                                ' Get the full saving path of the current attachment.
                                strAtmtPath = strFolderPath & atmt.FileName
                                
                                ' /* If the length of the saving path is not larger than 260 characters.*/
                                If Len(strAtmtPath) <= MAX_PATH Then
                                    ' True: This attachment can be saved.
                                    blnIsSave = True
                                    
                                    ' /* Loop until getting the file name which does not exist in the folder. */
                                    Do While objFSO.FileExists(strAtmtPath)
                                        strAtmtNameTemp = strAtmtName(0) & _
                                                          Format(Now, "_mmddhhmmss") & _
                                                          Format(Timer * 1000 Mod 1000, "000")
                                        strAtmtPath = strFolderPath & strAtmtNameTemp & "." & strAtmtName(1)
                                            
                                        ' /* If the length of the saving path is over 260 characters.*/
                                        If Len(strAtmtPath) > MAX_PATH Then
                                            lCountEachItem = lCountEachItem - 1
                                            ' False: This attachment cannot be saved.
                                            blnIsSave = False
                                            Exit Do
                                        End If
                                    Loop
                                    
                                    ' /* Save the current attachment if it is a valid file name. */
                                    If blnIsSave Then atmt.SaveAsFile strAtmtPath
                                Else
                                    lCountEachItem = lCountEachItem - 1
                                End If
                            ElseIf Err.Number > 0 Then
                                On Error GoTo 0
                                Print #2, objItem.EntryID & "," & "Error" & "," & strFolderPath
                                
                            Else
                                On Error GoTo 0
                                Print #2, objItem.EntryID & "," & atmt.FileName & "," & strFolderPath
                            End If
                            On Error GoTo 0
                        Next
                    End If
                    
                    ' Count the number of attachments in all Outlook items.
                    lCountAllItems = lCountAllItems + lCountEachItem
                Next
                Close #3
                Close #2
                Close #1
            End If
        Else
            MsgBox "Failed to get the handle of Outlook window!", vbCritical, "Error from Attachment Saver"
            blnIsEnd = True
            GoTo PROC_EXIT
        End If
        
    ' /* For run-time error:
    '    The Explorer has been closed and cannot be used for further operations.
    '    Review your code and restart Outlook. */
    Else
        MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
        blnIsEnd = True
    End If
    
PROC_EXIT:
    SaveAttachmentsFromSelection = lCountAllItems
    
    ' /* Release memory. */
    If Not (objFSO Is Nothing) Then Set objFSO = Nothing
    If Not (objItem Is Nothing) Then Set objItem = Nothing
    If Not (selItems Is Nothing) Then Set selItems = Nothing
    If Not (atmt Is Nothing) Then Set atmt = Nothing
    If Not (atmts Is Nothing) Then Set atmts = Nothing
    
    ' /* End all code execution if the value of blnIsEnd is True. */
    If blnIsEnd Then End
    
    If lCountAllItems > 0 Then
        MsgBox CStr(lCountAllItems) & " attachment(s) was(were) saved successfully from " & i & " Emails.", vbInformation, "Message from Attachment Saver"
    Else
        MsgBox "No attachment(s) in the selected Outlook items.", vbInformation, "Message from Attachment Saver"
    End If
End Function

' #####################
' Convert general path.
' #####################
Public Function CGPath(ByVal Path As String) As String
    If Right(Path, 1) <> "\" Then Path = Path & "\"
    CGPath = Path
End Function

' ######################################
' Run this macro for saving attachments.
' ######################################
Public Sub ExecuteSaving()
    Dim lNum As Long
    
    lNum = SaveAttachmentsFromSelection
    
    
End Sub

Public Function F_Body(sBody As String)
    
    'Remove Vertical Tabs
    sBody = Replace(sBody, Chr(13), "")
    
    'Remove Horizontal Tabs
    sBody = Replace(sBody, Chr(9), "")
    
    'Remove new line
    sBody = Replace(sBody, Chr(10), "")
    
    'Remove 'excessive' spaces
    Do While InStr(1, sBody, "  ") > 0
    
        sBody = Replace(sBody, "  ", " ")
        
    Loop
    
    F_Body = sBody
End Function
So with this code, it will extract the attachments and put it into a folder onto your local drive. There will be a few .txt docs within that file. Simply extract the .txt file onto access and it will populate the access database.


The files extracted are
1. pst- this one contains the metadata for the email. Including sender, reciever, the data recived, created, modified,

2.attachments- this one has the metadata for the attachments, so it will save all the attachments in one row each. just change the attachment link header to hyperlink file type and you can click on it to open the file on your local drive
3. body- this one contains the body of the email. I am getting alot of errors with this one, but it seems to be because of images attached to the email body (banners) so be aware


all entries have an entry ID which is unique to the email.


hopefully this will help a future weary learner. The only thing i cannot figure out is how to extract the email as an .msg into a local folder and create a link to it in the same way i did for attachments.


I also keep running into max length. I have emails were the subject line is over 256 characters. Wonder if i can increase it?


In any case all credit goes to VBA_PHP and Gasman. thanks guys
 
Last edited:

vba_php

Forum Troll
Local time
Today, 07:52
Joined
Oct 6, 2019
Messages
2,884
hopefully this will help a future weary learner. The only thing i cannot figure out is how to extract the email as an .msg into a local folder and create a link to it in the same way i did for attachments.
I would assume all you have to do is look the code up for this process:

https://kb.intermedia.net/Article/2581
I also keep running into max length. I have emails were the subject line is over 256 characters. Wonder if i can increase it?
i would doubt it. it's prolly a system bit limit, like those other popular ones we know so well...512, 1024, etc...

i didn't read thru all ur code, but r u saying ur trying to save subject text (the subject "attribute" of an email message) to an access field and the field max length is 256? in pre-2016 access version, i think there are 2 text type fields => TEXT and MEMO. in 2016 they changed it and I think it's SHORT TEXT and LONG TEXT. I haven't tested it, but it's prolly the same thing as TEXT and MEMO. Just change the field type to accept longer text strings and it should work fine.
 

Gasman

Enthusiastic Amateur
Local time
Today, 12:52
Joined
Sep 21, 2011
Messages
14,052
My first port of call is always google.

https://www.slipstick.com/developer/code-samples/save-selected-message-file/

from

https://www.google.com/search?q=sav...1.69i57j0l6.8891j0j7&sourceid=chrome&ie=UTF-8


The only thing i cannot figure out is how to extract the email as an .msg into a local folder and create a link to it in the same way i did for attachments.


I also keep running into max length. I have emails were the subject line is over 256 characters. Wonder if i can increase it?


In any case all credit goes to VBA_PHP and Gasman. thanks guys
 

Users who are viewing this thread

Top Bottom