Results 1 to 9 of 9

Thread: Outlook to Excel to Access database

  1. #1

    Thread Starter
    New Member
    Join Date
    Feb 2009
    Posts
    4

    Outlook to Excel to Access database

    I am setting up a database from a report that is generated and automatically sent to me every hour. I have made a macro to edit this report in excel. And after it is edited I need it saved then imported into my database (access).

    I am able to get the attachment to download but am unable to get the VB script I am using to even open excel much less edit the file by using the macro I created. Any help would be appreciated.

    I will be taking out any and all File GET references as I do not want anyone requesting or getting these files from my computer.

    *NOTE - The basic code is from http://www.codeforexcelandoutlook.com but I have edited quite a few parts of it for my specific application.



    Code:
    Private WithEvents Items As Outlook.Items
    
      
    
    Private Sub Application_Startup()
    
    Dim objNS As Outlook.NameSpace
    
      Set objNS = GetNamespace("MAPI")
    
      Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
        
    End Sub
    
    Private Sub Items_ItemAdd(ByVal Item As Object)
    
    ' -------------------------------------------------------------------
    ' File Request System v1.0
    ' code by Jimmy Pena, 4-4-2008
    ' http://www.codeforexcelandoutlook.com
    ' To request a file, subject should be:
    ' Subject: FILEGET C:\MyFile.doc
    ' To send a file to a folder, subject should be:
    ' Subject: FILEPUT C:\
    ' 1. There should be at least one attachment
    ' 2. All attachments will be saved to the same folder
    ' Scripting Runtime object library is late-bound, you can change
    ' to early-bound by: a) Add a reference to the Scripting Runtime
    ' object library in Tools>References of the VBE
    ' b) Change "Dim fso As Object" to
    ' "Dim fso As Scripting.FileSystemObject"
    ' c) Change
    ' "Set fso = CreateObject("Scripting.FileSystemObject")" to
    ' "Set fso = New Scripting.FileSystemObject"
    ' -------------------------------------------------------------------
    
    If TypeName(Item) = "MailItem" Then
        Dim ToDo As String
        Dim WhatAndWhere As String
        Dim Msg As Outlook.MailItem
        Dim MsgAttach As Outlook.Attachments
        Dim MsgReply As Outlook.MailItem
        Dim SlashSign As Long
        Dim sPath As String
        Dim sFile As String
        Dim fso As Object
        Dim UserN As String
        Dim DeskTopSharedFolder As String
        Dim strHelpText As String
        Dim objxlOutApp As Object 'Excel.Application
        Dim objxlOutWBook As Object 'Excel.Workbook
        Dim objxlOutSheet As Object 'Excel.Worksheet
        Dim objxlRange As Object 'Excel.Range
      
        Const strNoFolder As String = "Error: That folder does not " & _
        "exist, please resubmit with a valid folder name."
        Const strNoFilename As String = "Error: The filename should " & _
        "not be in the subject line. Please resubmit."
        Const strNoAttach As String = "Error: I'm sorry, there does " & _
        "not appear to be any attachments to your email. " & _
        "Please resend your request with the attachments you want saved."
        Const strBadSubject As String = "Error: I don't understand that " & _
        "subject. Please try again."
        Const strNoAccess As String = "Error: That folder cannot be " & _
        "accessed. Please choose another folder and try again."
        Const strNoFile As String = "Error: File doesn't exist. " & _
        "Please check the folder name and spelling."
          
        Set Msg = Item
      
        ' get current username so we can figure out the desktop folder name
        UserN = Environ("username")
        DeskTopSharedFolder = "D:\"
      
        On Error Resume Next
        ToDo = Left$(Msg.Subject, 7)
        WhatAndWhere = Right$(Msg.Subject, Len(Msg.Subject) - 8)
        On Error GoTo 0
      
    Select Case Msg.Subject
        Case "FILEGET HELP", "FILEPUT HELP", "FILE GET HELP", "FILE PUT HELP", _
     "fileget help", "fileput help", "file get help", "file put help"
        strHelpText = "Welcome to the File Request System!"
        strHelpText = strHelpText & vbCr & vbCr & "To request a file:"
        strHelpText = strHelpText & vbCr & _
    "Send a blank email with FILEGET drive:path\filename in the subject. (without quotes)"
        strHelpText = strHelpText & vbCr & _
    "Where 'drive:path\filename' is the full path and filename of the file you want."
        strHelpText = strHelpText & vbCr & "Ex: FILEGET E:\MyFolder\MyFile.doc"
        strHelpText = strHelpText & vbCr & vbCr & "To send a file:"
        strHelpText = strHelpText & vbCr & _
    "Send a blank email with FILEPUT [path] in the subject. (without quotes)"
        strHelpText = strHelpText & vbCr & _
    "There should be at least one attachment. All files will be placed in the folder you specify."
        strHelpText = strHelpText & vbCr & "Ex: FILEPUT D:\"
        strHelpText = strHelpText & vbCr & vbCr & _
    "To request this help text, send a blank email with" & _
    "FILEGET HELP or FILEPUT HELP in the subject."
      
            Call SendMsg(Msg, strHelpText, , Msg.Subject)
            GoTo ExitProc
    End Select
          
        If (ToDo <> "FILEGET") And (ToDo <> "FILEPUT") Then
            GoTo ExitProc
        End If
      
        Select Case ToDo
            Case "FILEGET", "fileget"
              
                ' check for valid folder/file name
                ' if there is no backslash, it has to be malformed
                  
                SlashSign = InStrRev(WhatAndWhere, "\")
                If SlashSign = 0 Then
                    Call SendMsg(Msg, strBadSubject, , ToDo)
                    GoTo ExitProc
                End If
                  
                ' test the path to make sure it is valid, and
                ' that it isn't the C:\ drive (except for special desktop\shared folder
                ' where we allow users to place files they want to share
                  
                sPath = Left$(WhatAndWhere, SlashSign)
                If (Left$(sPath, 3) = "C:\") Or (Left$(sPath, 3) = "c:\") Then
                    If sPath <> DeskTopSharedFolder Then
                        Call SendMsg(Msg, strNoAccess, , ToDo)
                        GoTo ExitProc
                    End If
                End If
          
                ' check if path & file exists!
                Set fso = CreateObject("Scripting.FileSystemObject")
                 
                sFile = Right$(WhatAndWhere, Len(WhatAndWhere) - SlashSign)
                  
                If fso.FileExists(sPath & sFile) = False Then
                    ' file doesn't exist
                    ' send err msg to requestor
                    Call SendMsg(Msg, strNoFile, , ToDo)
                    GoTo ExitProc
                End If
                  
                Call FileServ(Msg, ToDo, WhatAndWhere)
    '---------------------------------------------------------------------
    ' what to do with orig msg?
    ' a) to simply mark as read, uncomment this line of code:
    '
    ' Msg.UnRead = False
    '
    ' b) to move to a folder, uncomment this section of code:
    '
    'Dim MoveFolder As Outlook.MAPIFolder
    'Dim olApp As Application
    'Dim olNS As NameSpace
    'On Error Resume Next
    '    Set olApp = Application
    '    Set olNS = olApp.GetNamespace("MAPI")
    '    Set MovetoFolder = olNS.GetDefaultFolder(olFolderInbox).Folders("File")
    'On Error GoTo 0
    '
    'If MoveFolder = 0 Then
    '    Set MoveFolder = olNS.GetDefaultFolder(olFolderInbox).Folders.Add("File")
    'End If
    '
    'With Msg
    '.UnRead = False
    '.Move MoveFolder
    'End With
    '---------------------------------------------------------------------
            Case "FILEPUT", "fileput"
                ' if the filename is in the path,
                ' the fourth to last character will be a period
                ' check for valid folder
                If Right$(WhatAndWhere, 1) <> "\" Then
                    WhatAndWhere = WhatAndWhere & "\"
                End If
                  
                Set fso = CreateObject("Scripting.FileSystemObject")
                If fso.FolderExists(WhatAndWhere) = False Then
                ' bad folder in subject line
                    Call SendMsg(Msg, strNoFolder, , ToDo)
                    GoTo ExitProc
                End If
      
                ' the file(s) should be attached, if not, exit
                Set MsgAttach = Msg.Attachments
                If Msg.Attachments.Count > 0 Then
                    Call FileServ(Msg, ToDo, WhatAndWhere)
                Else
                    ' no attachments, send stock reply
                    Call SendMsg(Msg, strNoAttach, , ToDo)
                    GoTo ExitProc
                End If
                
                 ' open wkbk and run import macro
            Dim olDestFldr As Outlook.MAPIFolder
            Set objxlOutApp = CreateObject("Excel.Application") 'New Excel.Application
            Set objxlOutWBook = objxlOutApp.Workbooks.Add '.Add.Sheets
            Set objxlOutSheet = objxlOutWBook.Sheets.Item(1)
            Dim Att As String
               
            Const attPath As String = "D:\"
               
            ' save attachment
            Set myAttachments = Item.Attachments
            Att = myAttachments.Item(1).DisplayName
            myAttachments.Item(1).SaveAsFile attPath & Att
               
            ' open Test.xls where macro is stored, just in case it doesn't open on its own
            On Error Resume Next
            XLApp.Workbooks.Open ("d:\Test.XLS")
            XLApp.Run ("Test.XLS!Reportupdate")
            On Error GoTo 0
        End Select
    End If
    
    
    ExitProc:
    Set fso = Nothing
    Set MsgReply = Nothing
    Set MsgAttach = Nothing
    Set Msg = Nothing
      
    End Sub
    Last edited by winz3_16; Feb 6th, 2009 at 08:58 PM.

  2. #2

    Thread Starter
    New Member
    Join Date
    Feb 2009
    Posts
    4

    Re: Outlook to Excel to Access database

    Here is the Module I am using currently.

    Code:
    Option Explicit
      
    Sub FileServ(Msg As Outlook.MailItem, sType As String, Optional sFilePath As String)
    
    ' -----------------------------------------------------------------------------------
    ' File Server portion of the File Put/Get System Code
    ' by Jimmy Pena, 4-4-2008
    ' http://www.codeforexcelandoutlook.com
    '
    ' This sub takes the already-validated user input, determines whether it is
    ' a 'GET' or a 'PUT' request, and calls the sending sub appropriately
    ' -----------------------------------------------------------------------------------
    '
    Dim MsgAttach As Outlook.Attachments
    Dim MsgReply As Outlook.MailItem
    Dim strRecd As String
    Dim i As Long
    Dim Att As String
    Dim strErr As String
      
    Const strErrStart As String = "The following files were not saved: "
    Const strSent As String = "Attached is the file you requested."
      
    strRecd = "The files you sent have been saved to the " & sFilePath & " folder."
      
    Select Case sType
        Case "FILEGET", "fileget"
            Call SendMsg(Msg, strSent, sFilePath, sType)
          
        Case "FILEPUT", "fileput"
            Set MsgAttach = Msg.Attachments
                For i = 1 To Msg.Attachments.Count
                    Att = MsgAttach.Item(i).DisplayName
      
    ' -----------------------------------------------------------------------------------
    ' If any of the files cannot be saved, build a string with the filenames and
    ' send a msg back to requestor with those filenames
    ' -----------------------------------------------------------------------------------
                    On Error Resume Next
                    MsgAttach.Item(i).SaveAsFile sFilePath & Att
                    If Err <> 0 Then
                        strErr = strErr & Att
                    End If
                    On Error GoTo 0
                Next i
      
            If strErr <> "" Then
                Call SendMsg(Msg, strErrStart & strErr, , sType)
                GoTo ExitProc
            End If
              
            Call SendMsg(Msg, strRecd, , sType)
    End Select
      
    ExitProc:
    Set MsgAttach = Nothing
    End Sub
      
    Sub SendMsg(Msg As Outlook.MailItem, sMsg As String, Optional sFilePath As String, Optional sType As String)
      
    ' -----------------------------------------------------------------------------------
    ' This sub is responsible for sending all responses, whether it is:
    ' a) error msgs for malformed requests;
    ' b) ack email to original requestor of successful 'PUT' request
    ' c) ack email with attachments for successful 'GET' request
    ' This sub itself calls the logging routine that appends the request to a CSV file for later review
    ' -----------------------------------------------------------------------------------
      
    Dim MsgReply As Outlook.MailItem
    Dim MsgRecip As Outlook.Recipient
    Dim arr() As String
    Dim strRecips As String
    Dim i As Long
      
    Set MsgReply = Msg.Reply
      
    With MsgReply
        '.To = Msg.SenderName
        .BodyFormat = olFormatPlain
        .Body = sMsg
        .Subject = "Your File Request"
        '.Recipients.ResolveAll
          
        ' ----------------------------------------------------------------
        ' If you regularly send emails 'on behalf of' another, and
        ' want to use this feature here, just un-comment the line
        ' below and edit "My Email Name" to reflect the person
        ' or email address you are sending on behalf of.
        ' ----------------------------------------------------------------
          
        ' .SentOnBehalfOfName = "My Email Name"
          
        If sFilePath <> "" Then
            .Attachments.Add sFilePath
        End If
          
        strRecips = MsgReply.Recipients.Item(1)
      
        .Send
    End With
      
    ' ------------------------------------------------------------------------------------
    ' Simply comment out the line below if you don't want the logging feature.
    ' You should also comment out or remove the LogInformation sub below
    ' ------------------------------------------------------------------------------------
      
    '--LogInformation strRecips & "," & sType & "," & sFilePath & "," & _
        MsgReply.Attachments.Count & "," & Date, "C:\FileRequestLog.csv"
      
    '--Set MsgReply = Nothing
    '--Set MsgRecip = Nothing
    End Sub

  3. #3
    Super Moderator si_the_geek's Avatar
    Join Date
    Jul 2002
    Location
    Bristol, UK
    Posts
    41,929

    Re: Outlook to Excel to Access database

    Welcome to VBForums

    Thread moved to Office Development/VBA forum (note that the "VB Editor" in Office programs is actually VBA rather than VB, so the VB6 forum is not really apt). You should also avoid the phrase "VB script", as VBScript is another programming language!

    The first thing I would recommend is reading the article What is wrong with using "On Error Resume Next"? (it is for VB6, but applies to VBA too).

    In terms of interacting with Excel, see the Excel Tutorial link in my signature - again it is designed for VB6, but is identical apart from setting the Reference (instead of "Project"->"References", you need "Tools"->"References").

  4. #4
    Ex-Super Mod RobDog888's Avatar
    Join Date
    Apr 2001
    Location
    LA, Calif. Raiders #1 AKA:Gangsta Yoda™
    Posts
    60,710

    Re: Outlook to Excel to Access database

    You are creating an Excel application object with objxlOutApp but you are not using it in the rest of your code.

    'Created:
    Set objxlOutApp = CreateObject("Excel.Application")

    Used:
    XLApp.Workbooks.Open ("d:\Test.XLS")

    So it will never work that way. Use the created object variable in your code throughout.


    For ex:
    Set objxlOutApp = CreateObject("Excel.Application")
    objxlOutApp.Workbooks.Open ("d:\Test.XLS")

    VB/Office Guru™ (AKA: Gangsta Yoda®)
    I dont answer coding questions via PM. Please post a thread in the appropriate forum.

    Microsoft MVP 2006-2011
    Office Development FAQ (C#, VB.NET, VB 6, VBA)
    Senior Jedi Software Engineer MCP (VB 6 & .NET), BSEE, CET
    If a post has helped you then Please Rate it!
    Reps & Rating PostsVS.NET on Vista Multiple .NET Framework Versions Office Primary Interop AssembliesVB/Office Guru™ Word SpellChecker™.NETVB/Office Guru™ Word SpellChecker™ VB6VB.NET Attributes Ex.Outlook Global Address ListAPI Viewer utility.NET API Viewer Utility
    System: Intel i7 6850K, Geforce GTX1060, Samsung M.2 1 TB & SATA 500 GB, 32 GBs DDR4 3300 Quad Channel RAM, 2 Viewsonic 24" LCDs, Windows 10, Office 2016, VS 2019, VB6 SP6

  5. #5

    Thread Starter
    New Member
    Join Date
    Feb 2009
    Posts
    4

    Re: Outlook to Excel to Access database

    Thanks for the replies and sorry for having posted this in the wrong section. I have edited the code and taken out the XLApp and replaced it with objxloutapp for all instances yet Excel does not start up.

  6. #6
    Hyperactive Member Davadvice's Avatar
    Join Date
    Apr 2007
    Location
    Glasgow (Scotland)
    Posts
    440

    Re: Outlook to Excel to Access database

    hi and welcome,

    for excell you may want to check out this thread

    my post will show you how to open and close excel.

    http://www.vbforums.com/showthread.php?t=553806

    if you need more help let us know
    David
    This is Blank

  7. #7

    Thread Starter
    New Member
    Join Date
    Feb 2009
    Posts
    4

    Re: Outlook to Excel to Access database

    Thanks a TON Davadvice. That is exactly what I needed to get the file to open the excel macro and run it on the downloaded file and save it. Now to work on getting that same file imported into the database I have setup. I'll get back with you all when I get some stuff written for that part of the process.

  8. #8

    Thread Starter
    New Member
    Join Date
    Feb 2009
    Posts
    4

    Re: Outlook to Excel to Access database

    Ok I have got the completed code to work...however, after I get the first file and it gets edited in excel and then imported into access I get a debug error on the following file that is sent. Apparantly my code is not closing excel or access after it run's. Is there a specific command I need to run in the VBA to have it clean up after itself?

    Here is my stuff so far:
    Code:
    Private WithEvents Items As Outlook.Items
    
      
    
    Private Sub Application_Startup()
    
    Dim objNS As Outlook.NameSpace
    
      Set objNS = GetNamespace("MAPI")
    
      Set Items = objNS.GetDefaultFolder(olFolderInbox).Items
        
    End Sub
    
    Private Sub Items_ItemAdd(ByVal Item As Object)
    
    ' -------------------------------------------------------------------
    ' File Request System v1.0
    ' code by Jimmy Pena, 4-4-2008
    ' http://www.codeforexcelandoutlook.com
    ' To request a file, subject should be:
    ' Subject: FILEGET C:\MyFile.doc
    ' To send a file to a folder, subject should be:
    ' Subject: FILEPUT C:\
    ' 1. There should be at least one attachment
    ' 2. All attachments will be saved to the same folder
    ' Scripting Runtime object library is late-bound, you can change
    ' to early-bound by: a) Add a reference to the Scripting Runtime
    ' object library in Tools>References of the VBE
    ' b) Change "Dim fso As Object" to
    ' "Dim fso As Scripting.FileSystemObject"
    ' c) Change
    ' "Set fso = CreateObject("Scripting.FileSystemObject")" to
    ' "Set fso = New Scripting.FileSystemObject"
    ' -------------------------------------------------------------------
    
      
    
    If TypeName(Item) = "MailItem" Then
        Dim ToDo As String
        Dim WhatAndWhere As String
        Dim Msg As Outlook.MailItem
        Dim MsgAttach As Outlook.Attachments
        Dim MsgReply As Outlook.MailItem
        Dim SlashSign As Long
        Dim sPath As String
        Dim sFile As String
        Dim fso As Object
        Dim UserN As String
        Dim DeskTopSharedFolder As String
        Dim strHelpText As String
        Dim xl As Excel.Application
        Dim wbk As Excel.Workbook
        Dim wsht As Excel.Worksheet
        Dim strFileName As String
        Dim lastRow As Integer
        Dim appAccess As Access.Application
        Dim cyear As String                             '-- String for Year in #### format example (2009)
        Dim cmonth As String                            '-- String for Month in long formate example (January)
        Dim cToday As String                            '-- String for Todays Date Example (01-28-2009)
        Dim ctime As String                             '-- String for current Time Stamp
            
        Const strNoFolder As String = "Error: That folder does not " & _
        "exist, please resubmit with a valid folder name."
        Const strNoFilename As String = "Error: The filename should " & _
        "not be in the subject line. Please resubmit."
        Const strNoAttach As String = "Error: I'm sorry, there does " & _
        "not appear to be any attachments to your email. " & _
        "Please resend your request with the attachments you want saved."
        Const strBadSubject As String = "Error: I don't understand that " & _
        "subject. Please try again."
        Const strNoAccess As String = "Error: That folder cannot be " & _
        "accessed. Please choose another folder and try again."
        Const strNoFile As String = "Error: File doesn't exist. " & _
        "Please check the folder name and spelling."
          
        Set Msg = Item
      
        ' get current username so we can figure out the desktop folder name
        UserN = Environ("username")
        DeskTopSharedFolder = "D:\"
      
        On Error Resume Next
        ToDo = Left$(Msg.Subject, 7)
        WhatAndWhere = Right$(Msg.Subject, Len(Msg.Subject) - 8)
        On Error GoTo 0
      
    Select Case Msg.Subject
        Case "FILEGET HELP", "FILEPUT HELP", "FILE GET HELP", "FILE PUT HELP", _
     "fileget help", "fileput help", "file get help", "file put help"
        strHelpText = "Welcome to the File Request System!"
        strHelpText = strHelpText & vbCr & vbCr & "To request a file:"
        strHelpText = strHelpText & vbCr & _
    "Send a blank email with FILEGET drive:path\filename in the subject. (without quotes)"
        strHelpText = strHelpText & vbCr & _
    "Where 'drive:path\filename' is the full path and filename of the file you want."
        strHelpText = strHelpText & vbCr & "Ex: FILEGET E:\MyFolder\MyFile.doc"
        strHelpText = strHelpText & vbCr & vbCr & "To send a file:"
        strHelpText = strHelpText & vbCr & _
    "Send a blank email with FILEPUT [path] in the subject. (without quotes)"
        strHelpText = strHelpText & vbCr & _
    "There should be at least one attachment. All files will be placed in the folder you specify."
        strHelpText = strHelpText & vbCr & "Ex: FILEPUT D:\"
        strHelpText = strHelpText & vbCr & vbCr & _
    "To request this help text, send a blank email with" & _
    "FILEGET HELP or FILEPUT HELP in the subject."
      
            Call SendMsg(Msg, strHelpText, Msg.Subject)
            GoTo ExitProc
    End Select
          
        If (ToDo <> "FILEGET") And (ToDo <> "FILEPUT") Then
            GoTo ExitProc
        End If
      
        Select Case ToDo
            Case "FILEGET", "fileget"
              
                ' check for valid folder/file name
                ' if there is no backslash, it has to be malformed
                  
                SlashSign = InStrRev(WhatAndWhere, "\")
                If SlashSign = 0 Then
                    Call SendMsg(Msg, strBadSubject, , ToDo)
                    GoTo ExitProc
                End If
                  
                ' test the path to make sure it is valid, and
                ' that it isn't the C:\ drive (except for special desktop\shared folder
                ' where we allow users to place files they want to share
                  
                sPath = Left$(WhatAndWhere, SlashSign)
                If (Left$(sPath, 3) = "C:\") Or (Left$(sPath, 3) = "c:\") Then
                    If sPath <> DeskTopSharedFolder Then
                        Call SendMsg(Msg, strNoAccess, , ToDo)
                        GoTo ExitProc
                    End If
                End If
          
                ' check if path & file exists!
                Set fso = CreateObject("Scripting.FileSystemObject")
                 
                sFile = Right$(WhatAndWhere, Len(WhatAndWhere) - SlashSign)
                  
                If fso.FileExists(sPath & sFile) = False Then
                    ' file doesn't exist
                    ' send err msg to requestor
                    Call SendMsg(Msg, strNoFile, , ToDo)
                    GoTo ExitProc
                End If
                  
                Call FileServ(Msg, ToDo, WhatAndWhere)
    '---------------------------------------------------------------------
    ' what to do with orig msg?
    ' a) to simply mark as read, uncomment this line of code:
    '
    ' Msg.UnRead = False
    '
    ' b) to move to a folder, uncomment this section of code:
    '
    'Dim MoveFolder As Outlook.MAPIFolder
    'Dim olApp As Application
    'Dim olNS As NameSpace
    'On Error Resume Next
    '    Set olApp = Application
    '    Set olNS = olApp.GetNamespace("MAPI")
    '    Set MovetoFolder = olNS.GetDefaultFolder(olFolderInbox).Folders("File")
    'On Error GoTo 0
    '
    'If MoveFolder = 0 Then
    '    Set MoveFolder = olNS.GetDefaultFolder(olFolderInbox).Folders.Add("File")
    'End If
    '
    'With Msg
    '.UnRead = False
    '.Move MoveFolder
    'End With
    '---------------------------------------------------------------------
            Case "FILEPUT", "fileput"
                ' if the filename is in the path,
                ' the fourth to last character will be a period
                ' check for valid folder
                If Right$(WhatAndWhere, 1) <> "\" Then
                    WhatAndWhere = WhatAndWhere & "\"
                End If
                  
                Set fso = CreateObject("Scripting.FileSystemObject")
                If fso.FolderExists(WhatAndWhere) = False Then
                ' bad folder in subject line
                    Call SendMsg(Msg, strNoFolder, , ToDo)
                    GoTo ExitProc
                End If
      
                ' the file(s) should be attached, if not, exit
                Set MsgAttach = Msg.Attachments
                If Msg.Attachments.Count > 0 Then
                    Call FileServ(Msg, ToDo, WhatAndWhere)
                Else
                    ' no attachments, send stock reply
                    Call SendMsg(Msg, strNoAttach, , ToDo)
                    GoTo ExitProc
                End If
                
                 ' open wkbk and run import macro
            Dim olDestFldr As Outlook.MAPIFolder
            Set xl = New Excel.Application 'New Excel.Application
            xl.DisplayAlerts = False
            Set wbk = xl.Workbooks.Add("d:\test.xls")  '.Add.Sheets
            Set wsht = xl.Sheets.Item(1)
            Dim Att As String
            
            wbk.SaveAs "D:\Test\temp.xls"
            xl.SaveWorkspace "wbk.Close"
            Set xl = Nothing
            Set XLApp = Nothing
                                          
            Const attPath As String = "D:\"
               
            ' save attachment
            Set myAttachments = Item.Attachments
            Att = myAttachments.Item(1).DisplayName
            myAttachments.Item(1).SaveAsFile attPath & Att
               
            ' open test.xls where macro is stored, just in case it doesn't open on its own
            On Error Resume Next
            xl.Workbooks.Open ("d:\Test.XLS")
            xl.Run ("Test.XLS!Reportupdate")
            On Error GoTo 0
            Set xl = Nothing
            Set XLApp = Nothing
        End Select
    End If
    
            Set appAccess = New Access.Application
            appAccess.Visible = True
            appAccess.Application.OpenCurrentDatabase ("D:\TimProject.mdb")
            DoCmd.RunMacro "Import"
            DoCmd.Close
            DoCmd.Quit
                    
    ExitProc:
    Set fso = Nothing
    Set MsgReply = Nothing
    Set MsgAttach = Nothing
    Set Msg = Nothing
      
    End Sub
    Eventually I want to be able to Save the files in their own month/date folder and timestamped which is why I included the Year month date and time in the dim's.

  9. #9
    Super Moderator si_the_geek's Avatar
    Join Date
    Jul 2002
    Location
    Bristol, UK
    Posts
    41,929

    Re: Outlook to Excel to Access database

    The way you work with Excel does need some refinement.

    For example, the way you specify which sheet to work with is not safe - you should be asking for a sheet within a specific workbook (eg: Set wsht = wbk.Sheets.Item(1) ) rather than letting Excel pick for you (depending on the circumstances, it may pick the wrong one). However, as you aren't actually using the wsht variable, you don't need to have it at all.

    As to how you close/disconnect the Excel objects, you are missing various things (such as closing the workbook), and have added things you probably don't need (such as SaveWorkspace). There is a post in my Excel Tutorial (I think post #5) that shows the valid ways to do it.


    Oh, and stop ignoring the problems VB is trying to tell you about - get rid of On Error Resume Next.

    If you are getting errors, alter the code so that they don't happen in the first place, and preferably add an error handler to deal with unexpected errors (note that it is easier to debug your code without one, so disable it while you are testing changes to the code).

    For example, this section of code:
    Code:
        On Error Resume Next
        ToDo = Left$(Msg.Subject, 7)
        WhatAndWhere = Right$(Msg.Subject, Len(Msg.Subject) - 8)
        On Error GoTo 0
    Should be like this:
    Code:
        ToDo = Left$(Msg.Subject, 7)
        If Len(Msg.Subject) > 8 Then
          WhatAndWhere = Right$(Msg.Subject, Len(Msg.Subject) - 8)
        End If
    This has the same behaviour, except when any other errors occur (you will be told about them, rather than not knowing why your code isn't doing what you expect it to).

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width