Consulting

Results 1 to 3 of 3

Thread: Help to amend vba to highlight any cells where file paths do not exists

  1. #1
    VBAX Regular
    Joined
    Feb 2018
    Posts
    70
    Location

    Help to amend vba to highlight any cells where file paths do not exists

    Hi, i'm hoping someone can help me adjust this code from Ron de Bruin. It attaches documents to an outlook email, where the file path is in cell E and F. It works great but I'd like to highlight the cells in E or F in yellow of any file paths which don't exist and therefore cannotbe attached. For example the file path is column E may attach but the one if column F may be typed incorrectly or may not exists so cannot be attached. I'd like to know if any are missing so I can correct them. Is this possible? Ive attached copy of the code. Many thanks


    Sub Send_Files()
    
    'Working in Excel 2000-2016
    'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Set sh = Sheets("Sheet1")
    
    Set OutApp = CreateObject("Outlook.Application")
    
    For Each cell In sh.Columns("A").Cells.SpecialCells(xlCellTypeConstants)
    
        'Enter the path/file names in the E:F column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("E1:F1")
        
        If cell.Value Like "?*@?*.?*" And _
        Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)
            
            With OutMail
                .to = sh.Cells(cell.Row, 1).Value
                .CC = sh.Cells(cell.Row, 2).Value
                .Subject = sh.Cells(cell.Row, 3).Value
                .Body = sh.Cells(cell.Row, 4).Value
                
                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell.Value) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell
                
                .display 'Or use .Display/Send
            End With
            
            Set OutMail = Nothing
        End If
    Next cell
    
    Set OutApp = Nothing
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    End Sub

  2. #2
    How about

               If Trim(FileCell.value) <> "" Then
                    If Dir(FileCell.value) <> "" Then
                        .Attachments.Add FileCell.value
                    Else
                        FileCell.Interior.Color = RGB(255, 255, 0)
                    End If
                End If
    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
    VBAX Regular
    Joined
    Feb 2018
    Posts
    70
    Location
    Thank you gmayor this works perfectly. You are a legend! thank you

Posting Permissions

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