Macro to move files does not move emails with attachments

[rachel06]

Hello!

I've been trying to use a macro to COPY emails that have attachments from one location to another without success. I've had success using this macro to move pdf and xlsx files but not with emails that have attachments. The person who set this up is no longer on my team ( ) but here's how it works:

Column A is the destination location
Column B is a search formula that looks into column C to determine column A (insignificant to this question)
Column C is the name of the file to be copied to destination location
Column D is the location of the file to be copied to destination location

I don't get a run-time error or anything because this macro is set up to move hundreds of files, and the ones that error are listed on a different sheet. The error I am getting is "bad file name or number." I know the file name is accurate because I can copy and paste the path from the workbook into file explorer and it opens. I have the "\" at the end of everything too. As it is set up now, I can move xlsx and pdfs, just not the emails with attachments. I'm sure the fact that it's not just a straight file is the issue I am running into, but I'm hoping this can be modified for it to work, or that there is a different solution.

This workbook has a lot of different macros that do a lot of different things. I believe this is the code that is used for the file moving.

Sub Copyfilefromto()

Dim mycheck As VbMsgBoxResult
       
    mycheck = MsgBox("Do you want to start the Copy Program ", vbYesNo)
    If mycheck = vbNo Then
        Exit Sub
        End If
    MsgBox "This will take time - More files the longer it will take"

Dim a As Long, x As Long
Dim FilePath As String
Dim FileName As String
Dim ErrCount As Long

ErrCount = 1

x = Worksheets("Query").Cells(Rows.Count, 3).End(xlUp).Row
For a = 4 To x

FilePath = Worksheets("Query").Cells(a, 4)
FileName = Worksheets("Query").Cells(a, 3)

On Error GoTo ErrorHandler

Call GetFileType(FileName, FilePath, a)

FileCopy Worksheets("Query").Cells(a, 4) & Worksheets("Query").Cells(a, 3), Worksheets("Query").Cells(a, 1) & NewName

Next a

MsgBox (Str(x - 3) & " Files Copied to Destinations")
Cells(2, 5).Value = x - 3
Exit Sub

ErrorHandler:
    Worksheets("ErrMsgs").Activate
    Cells(ErrCount, 1).Value = FileName
    Cells(ErrCount, 2).Value = Err.Description
    Worksheets("Query").Activate
    ErrCount = ErrCount + 1
Resume Next

End Sub
[\code]

Any help is greatly appreciated!

 

[rachel06]

Sort of bumping this, but I want to throw in an additional detail on this and offer a possible solution (for which I would need help with the code). Hoping this isn't against the rules or anything, but if it is I apologize!

I should have noted the emails are saved on the network - I'm not trying to pull them right from Outlook.

I've tried a few different codes on this and none of them will move these emails, but they'll still move the pdf and xlsx files. The code below gives the error of "file not found" but I know the file is there because I can paste the path into file explorer and it comes right up.

One off-the-wall solution I had is - is there a way to tell the macro to OPEN the file that's in column D and SAVE AS to the location in column A? What would that look like? Would it be really slow? I would love for it to work as written but I'm just coming up short.

Any help on this is greatly appreciated! I'm just so stumped why it moves my other files but not these msg files.

Sub Rename_and_move_files()
  Dim Path1 As String, Path2 As String, sName As String
  Dim i As Long

  For i = 2 To Range("A" & Rows.Count).End(3).Row
    Path1 = Range("A" & i).Value
    Path2 = Range("B" & i).Value
    If Right(Path2, 1) <> "\" Then Path2 = Path2 & "\"
    sName = Mid(Path1, InStrRev(Path1, "\") + 1)
    If Dir(Path1) <> "" Then
      If Dir(Path2, vbDirectory) <> "" Then
        Name Path1 As Path2 & sName
      End If
    End If
  Next
End Sub