Consulting

Results 1 to 4 of 4

Thread: I can't code well at all but I am trying to get this to work

  1. #1

    I can't code well at all but I am trying to get this to work

    I managed to cobble this together from a friend's help. Now I don't know how to finish it now that he can't help. If you have ANY idea what to do or what the problem may be, that would be great
    Sub SearchEmails() 
    Dim oExcel As Excel.Application 
    Dim oWorkbook As Excel.Workbook 
    Dim oWorksheet As Excel.Worksheet 
    Dim oRange As Excel.Range 
    Dim oItem As Object 
    Dim sEmail As String 
    Dim sPath As String 
    Dim sSpreadsheet As String 
    Dim sFilter As String 
    Dim oMail As MailItem  
    'Specify the path to the spreadsheet 'For example: "C:\Users\Bob\Documents\Emails.xlsx" sSpreadsheet = "S:\Marshall Wu\test file.xlsx"  
    'Create an instance of Excel and open the spreadsheet 
    Set oExcel = CreateObject("Excel.Application") 
    Set oWorkbook = oExcel.Workbooks.Open(sSpreadsheet) 
    Set oWorksheet = oWorkbook.Worksheets(1)  
    'Get the range of cells you want to read from 'For example: "A1:B10" 
    Set oRange = oWorksheet.Range("A1:B10")  
    'Loop through the cells in the range 
    For Each oItem In oRange.Cells 
       'Read the email address and file path from the cells
       sEmail = oItem.Value
       sPath = oItem.Offset(0, 1).Value
       'Print the values of sEmail and sPath to the immediate window
       Debug.Print "Email: " & sEmail & ", Path: " & sPath
       'Build the search filter
       sFilter = "[SenderEmailAddress] = '" & sEmail & "'"
       'Search the mailbox for emails from the specified sender
          For Each oMail In Outlook.Application.Session.GetDefaultFolder(olFolderAllFolders).Items.Restrict(sFilter)
              'Save the email to the specified folder
    oMail.SaveAs sPath & "" & oMail.Subject & ".msg" Next Next 'Close the spreadsheet and quit Excel oWorkbook.Close oExcel.Quit End Sub

    When I run the code, this error message appears: "Run-time error '-2147024809 (80070057)': Sorry, something went wrong. You may want to try again." When I click debug, it highlights this line "For Each oMail In Outlook.Application.Session.GetDefaultFolder(olFolderAllFolders).Items.Rest rict(sFilter)"

    Yay! I have no idea what is going on!

    This is what I have been trying to get this code to do. Read a from an excel spreadsheet and search my outlook mailbox from the data contained in the cells. And in the spreadsheet, column A will contain one or more email addresses. Column B will contain a file path. This code will search my outlook mailbox for these email addresses. For each entry in column A, save all search results to the file path listed in column B.


    I have no idea how to fix it or make this work

  2. #2
    olFolderAllFolders is not a valid Outlook folder. Either enter the correct folder e.g. olFolderInbox or loop hrough all the available folders.
    Your code makes no allowances for illegal filename characters in the message subject or for duplicated subjects. The former will crash the code. The latter will overwrite the earlier message.
    See http://www.gmayor.com/save_messages_from_outlook.html
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    Oh... thank you for the link but I have NO experience working with code at all. Do you know how I could combine that and fix that then?

  4. #4
    The following will create unique messages from Inbox in the folder indicated in column B of the worksheet that relate to the e-mail address in column A from rows 1 to 10.
    The folder must be a complete folder path which will be created if not already present e.g. C:\Path\Foldername\

    Option Explicit
    
    Sub SearchEmails()
    Dim oExcel As Object
    Dim oWorkbook As Object
    Dim oWorksheet As Object
    Dim oRange As Object
    Dim oItem As Object
    Dim sEmail As String
    Dim sPath As String
    Dim sName As String
    Dim sSpreadsheet As String
    Dim sFilter As String
    Dim oMail As MailItem
        'Specify the path to the spreadsheet 'For example: "C:\Users\Bob\Documents\Emails.xlsx"
        sSpreadsheet = "S:\Marshall Wu\test file.xlsx"
        
        'Create an instance of Excel and open the spreadsheet
        Set oExcel = CreateObject("Excel.Application")
        Set oWorkbook = oExcel.Workbooks.Open(sSpreadsheet)
        Set oWorksheet = oWorkbook.Worksheets(1)
        oExcel.Visible = True
        'Get the range of cells you want to read from 'For example: "A1:A10"
        Set oRange = oWorksheet.Range("A1:A10")
        'Loop through the cells in the range
        For Each oItem In oRange.cells
            'Read the email address and file path from the cells
            sEmail = oItem.Value
            sPath = oItem.Offset(0, 1).Value
            Do Until Right(sPath, 1) = "\"
                sPath = sPath & "\"
            Loop
            'Print the values of sEmail and sPath to the immediate window
            'Debug.Print "Email: " & sEmail & ", Path: " & sPath
            'Build the search filter
            sFilter = "[SenderEmailAddress] = '" & sEmail & "'"
            'Search the mailbox for emails from the specified sender
            For Each oMail In Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Items.Restrict(sFilter)
                'Save the email to the specified folder
                sName = CleanFileName(oMail.Subject)
                SaveUnique oMail, sPath, sName
            Next
        Next
        'Close the spreadsheet and quit Excel
    lbl_Exit:
        oWorkbook.Close
        oExcel.Quit
        Set oWorkbook = Nothing
        Set oExcel = Nothing
        Set oWorksheet = Nothing
        Set oItem = Nothing
        Set oMail = Nothing
        Exit Sub
    End Sub
    
    Private Function SaveUnique(oItem As Object, _
                                strPath As String, _
                                strFileName As String)
    'An Outlook macro by Graham Mayor - www.gmayor.com
    'Ensures that filenames are not overwritten
    Dim lngF As Long
    Dim lngName As Long
    Dim FSO As Object
        Set FSO = CreateObject("Scripting.FileSystemObject")
        lngF = 1
        lngName = Len(strFileName)
        Do While FSO.FileExists(strPath & strFileName & ".msg") = True
            strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
            lngF = lngF + 1
        Loop
        CreateFolders strPath
        oItem.SaveAs strPath & strFileName & ".msg"    '".txt", olTXT
    lbl_Exit:
        Exit Function
    End Function
    
    Private Sub CreateFolders(strPath As String)
    'A Graham Mayor/Greg Maxey AddIn Utility Macro
    Dim oFSO As Object
    Dim lng_PathSep As Long
    Dim lng_PS As Long
        If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
        lng_PathSep = InStr(3, strPath, "\")
        If lng_PathSep = 0 Then GoTo lbl_Exit
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        Do
            lng_PS = lng_PathSep
            lng_PathSep = InStr(lng_PS + 1, strPath, "\")
            If lng_PathSep = 0 Then Exit Do
            If Len(Dir(Left(strPath, lng_PathSep), vbDirectory)) = 0 Then Exit Do
        Loop
        Do Until lng_PathSep = 0
            If Not oFSO.FolderExists(Left(strPath, lng_PathSep)) Then
                oFSO.CreateFolder Left(strPath, lng_PathSep)
            End If
            lng_PS = lng_PathSep
            lng_PathSep = InStr(lng_PS + 1, strPath, "\")
        Loop
    lbl_Exit:
        Set oFSO = Nothing
        Exit Sub
    End Sub
    
    Private Function CleanFileName(strFileName As String) As String
    Dim arrInvalid() As String
    Dim lng_Index As Long
        'Define illegal characters (by ASCII CharNum)
        arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
        'Remove any illegal filename characters
        CleanFileName = strFileName
        For lng_Index = 0 To UBound(arrInvalid)
            CleanFileName = Replace(CleanFileName, Chr(arrInvalid(lng_Index)), Chr(95))
        Next lng_Index
    lbl_Exit:
        Exit Function
    End Function
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

Tags for this Thread

Posting Permissions

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