UtterAccess.com
X   Site Message
(Message will auto close in 2 seconds)

Welcome to UtterAccess! Please ( Login   or   Register )

Custom Search
 
   Reply to this topicStart new topic
> Is This Possible?, Access 2016    
 
   
WowAccess
post May 10 2019, 07:52 AM
Post#1



Posts: 26
Joined: 16-October 18



Hi, I have been tasked with archiving & documenting old outlook .msg files that are on external HDDs (saved Singley, not as .PST). I was planning to alter Daniel Pineault excellent sample and explanation on the FileSystemObject https://www.devhut.net/2013/09/08/vba-list-...eir-properties/

CODE
Option Compare Database
' Input Variables:
' ~~~~~~~~~~~~~~~~
' sPath     : Full path of folder to examine with trailing \
' sFilter   : specific file extension to limmit search to, leave blank to list all files
Function fGetDirFileInfo(sPath As String, Optional sFilter As String = "*")
On Error GoTo Error_Handler
    Dim db              As DAO.Database
    Dim rs              As DAO.Recordset
    Dim sFile           As String
    Dim fso             As Object
    Dim f               As Object

    sPath = TrailingSlash(sPath)
    Set db = CurrentDb()
    db.Execute "Delete * FROM tblFiles", dbFailOnError    'Wipe previous entries in the table so we only have the most recent request's data to work with
    Set rs = db.OpenRecordset("SELECT * FROM tblFiles")
    Set fso = CreateObject("Scripting.FileSystemObject")    'Ref: http://msdn.microsoft.com/en-us/library/ea5ht6ax%28v=vs.84%29.aspx
                                                            'http://ss64.com/vb/filesystemobject.html

    sFile = Dir(sPath & "*." & sFilter)
    Do While sFile <> vbNullString
        If sFile <> "." And sFile <> ".." Then
            Set f = fso.GetFile(sPath & "\" & sFile)
            With rs
                .AddNew
                rs![FileName] = sFile   'Could also use f.Name if we wanted to
                rs![FileSize] = f.Size    'We could just as easily use FileLen(sFile)
                rs![FileDateCreated] = f.DateCreated
                rs![FileDateLastModified] = f.DateLastModified
                rs![FileDateLastAccessed] = f.DateLastAccessed
                rs![FileType] = f.Type
                rs![FileAttributes] = f.Attributes
                .Update
            End With
        End If
        sFile = Dir    'Loop through the next file that was found
    Loop

Error_Handler_Exit:
    On Error Resume Next
    Set f = Nothing
    Set fso = Nothing
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Exit Function

Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: fGetDirFileInfo" & vbCrLf & _
           "Error Description: " & Err.Description, _
           vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function


But soon realised the additional .msg fields that I was also wanting to write to the table To, From, Subject etc aren’t accessible to the FSO. I have found lots of examples based if the msg was in an outlook folder but only 1 example for a local folder. Daniel again posted an example.
http://www.UtterAccess.com/forum/lofiversi...p/t2038947.html

CODE
Public Sub GetEmailProp()
    On Error GoTo Error_Handler
    Dim objOL                 As Object
    Dim objMsg                As Object
    Dim strPath               As String
    Dim strFilter             As String
    Dim strFile               As String

    Set objOL = CreateObject("Outlook.Application")

    strPath = "C:\MyPath\"
    strFilter = "msg"

    strFile = Dir$(strPath & "*." & strFilter)
    Do While strFile <> ""    'Loop through all the files in the directory by using Dir$ function
        Set objMsg = objOL.CreateItemFromTemplate(strPath & strFile)
        MsgBox objMsg.Subject, vbInformation, "Subject"
        strFile = Dir$
    Loop

Error_Handler_Exit:
    On Error Resume Next
    Set objOL = Nothing
    Set objMsg = Nothing
    Exit Sub

Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: GetEmailProp" & vbCrLf & _
           "Error Description: " & Err.Description, vbCritical, _
           "An Error has Occured!"
    Resume Error_Handler_Exit
End Sub


I added the extra email fields to the tblFiles To, From, Subject etc and started trying to merge the 2 codes but I've tried so many combinations I've got to the need help stage and want to start afresh. To quote my granny “ You've got yourself into a right snarl".
I believe I've to “feed” the results of the Dir$ to SQL and write to the tblFiles but need help can you point me in the right direction.

Thanks Lona



Go to the top of the page
 
DanielPineault
post May 10 2019, 09:28 AM
Post#2


UtterAccess VIP
Posts: 6,774
Joined: 30-June 11



Can you show us what you've done so far.

--------------------
Daniel Pineault (2010-2019 Microsoft MVP)
Professional Help: http://www.cardaconsultants.com
Free MS Access Code, Tips, Tricks and Samples: http://www.devhut.net

* Design should never say "Look at me". It should always say "Look at this". -- David Craib
* A user interface is like a joke, if you have to explain it, it's not that good! -- Martin LeBlanc


All code samples, demonstration databases, links,... are provided 'AS IS' and are to be used at your own risk! Take the necessary steps to check, validate ...(you are responsible for your choices and actions)
Go to the top of the page
 
WowAccess
post May 10 2019, 10:31 AM
Post#3



Posts: 26
Joined: 16-October 18



Hi Daniel, thanks for picking up my post again thumbup.gif I had been working on this at home & because i made such mess of it i deleted the lot. I'll get the folder out the Recycle bin and post the code tonight.
Go to the top of the page
 
WowAccess
post May 10 2019, 01:28 PM
Post#4



Posts: 26
Joined: 16-October 18



Looked through my code i had managed it rotflmao.gif Daniel it sure ain't pretty but its a start. I presume i have made 1000 errors ?


CODE
Public Sub GetEmailProp4()

'http://www.UtterAccess.com/forum/lofiversi...p/t2038947.html

    On Error GoTo Error_Handler
    Dim objOL                 As Object
    Dim objMsg                As Object
    Dim strPath               As String
    Dim strFilter             As String
    Dim strFile               As String

    Dim sFile           As String
    Dim fso             As Object
    Dim f               As Object
    

    Set objOL = CreateObject("Outlook.Application")
    Set fso = CreateObject("Scripting.FileSystemObject")


    strPath = "E:\BACKUP_DEC17\MSG_Files\"
    strFilter = "msg"

    strFile = Dir$(strPath & "*." & strFilter)
    Do While strFile <> ""    'Loop through all the files in the directory by using Dir$ function
        
        Set objMsg = objOL.CreateItemFromTemplate(strPath & strFile)
        Set f = fso.GetFile(strPath & "\" & strFile)
        
''Check that email fields are being pulled from msg
'Original                   MsgBox objMsg.Subject, vbInformation, "Subject"
'Try 1 Worked  MsgBox       MsgBox objMsg.Body
'Try 2 Worked  DebugPrint   Debug.Print objMsg.Subject; objMsg.To; objMsg.Body
'Try 3 Worked  "        "   Debug.Print "Sent to:" & objMsg.To & " Re Subject:" & objMsg.Subject

  ''Use the objMsg. items/fields to write to tblFiles  ''
' Test small sample of objMsg.fields
' List of objMsg fields at https://docs.microsoft.com/en-us/office/vba/api/outlook.mailitem.body
  
      Dim dbs As DAO.Database
    Dim rst As DAO.Recordset

   Set db = CurrentDb()
   Set rs = db.OpenRecordset("SELECT * FROM tblFiles")
    

With rs
                .AddNew
               rs![From] = objMsg.SenderEmailAddress
               rs![Subject] = objMsg.Subject
               rs![Received] = objMsg.SentOn
               rs![Contents] = objMsg.Body
  
                rs![FileName] = f.Name   'Could also use f.Name if we wanted to
                rs![FileSize] = f.Size    'We could just as easily use FileLen(sFile)
                rs![FileDateCreated] = f.DateCreated
                rs![FileDateLastModified] = f.DateLastModified
                rs![FileDateLastAccessed] = f.DateLastAccessed
                rs![FileType] = f.Type
                rs![FileAttributes] = f.Attributes
              
               .Update
End With

strFile = Dir$

    Loop

Error_Handler_Exit:
    On Error Resume Next
    Set objOL = Nothing
    Set objMsg = Nothing
    Exit Sub

Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: GetEmailProp" & vbCrLf & _
           "Error Description: " & Err.Description, vbCritical, _
           "An Error has Occured!"
    Resume Error_Handler_Exit
End Sub
Go to the top of the page
 
DanielPineault
post May 10 2019, 06:50 PM
Post#5


UtterAccess VIP
Posts: 6,774
Joined: 30-June 11



The following works fine for me. Hopefully it is what you are after.
CODE
Public Sub GetEmailProp4()
'http://www.UtterAccess.com/forum/lofiversi...p/t2038947.html
    On Error GoTo Error_Handler
    Dim objOL                 As Object
    Dim objMsg                As Object
    Dim strPath               As String    'Could be a const
    Dim strFilter             As String    'Could be a const
    Dim strFile               As String
    Dim fso                   As Object
    Dim f                     As Object
    Dim db                    As DAO.Database
    Dim rs                    As DAO.Recordset

    Set objOL = CreateObject("Outlook.Application")
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set db = CurrentDb()
    Set rs = db.OpenRecordset("SELECT * FROM tblFiles")

    strPath = "E:\BACKUP_DEC17\MSG_Files\"
    strFilter = "msg"

    strFile = Dir$(strPath & "*." & strFilter)
    Do While strFile <> ""    'Loop through all the files in the directory by using Dir$ function
        Set objMsg = objOL.CreateItemFromTemplate(strPath & strFile)
        Set f = fso.GetFile(strPath & strFile)

        With rs
            .AddNew
            ![From] = objMsg.SenderEmailAddress
            ![Subject] = objMsg.Subject
            ![Received] = objMsg.SentOn
            ![Contents] = objMsg.Body
            ![FileName] = f.Name   'Could also use f.Name if we wanted to
            ![FileSize] = f.Size    'We could just as easily use FileLen(strFile)
            ![FileDateCreated] = f.DateCreated
            ![FileDateLastModified] = f.DateLastModified
            ![FileDateLastAccessed] = f.DateLastAccessed
            ![FileType] = f.Type
            ![FileAttributes] = f.Attributes
            .Update
        End With

        strFile = Dir$
    Loop

Error_Handler_Exit:
    On Error Resume Next
    rs.Close
    Set rs = Nothing
    Set db = Nothing
    Set objOL = Nothing
    Set objMsg = Nothing
    Exit Sub

Error_Handler:
    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
           "Error Number: " & Err.Number & vbCrLf & _
           "Error Source: GetEmailProp4" & vbCrLf & _
           "Error Description: " & Err.Description & _
           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
           , vbOKOnly + vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Sub

--------------------
Daniel Pineault (2010-2019 Microsoft MVP)
Professional Help: http://www.cardaconsultants.com
Free MS Access Code, Tips, Tricks and Samples: http://www.devhut.net

* Design should never say "Look at me". It should always say "Look at this". -- David Craib
* A user interface is like a joke, if you have to explain it, it's not that good! -- Martin LeBlanc


All code samples, demonstration databases, links,... are provided 'AS IS' and are to be used at your own risk! Take the necessary steps to check, validate ...(you are responsible for your choices and actions)
Go to the top of the page
 


Custom Search


RSSSearch   Top   Lo-Fi    23rd August 2019 - 02:42 PM