Check for file needed that will be in 1 of 2 locations

[gmooney]

I have some code that is rather long but 2 particular procedures are looking for a file. The first procedure (CheckforDuplicateDownloadFile) currently checks in the users Downloads folder and the second procedure (CheckforDesktopDuplicateFile) currently checks in the users Desktop folder. I just found out my users could potentially be using OneDrive and have the standard Downloads and Desktop folders mapped into the OneDrive folder.

For example, currently I am looking for a file in C:\users\{username}\Downloads or C:\users\{username}\Desktop but now I also need to look at C:\users\{username}\OneDrive - Company123\Downloads or C:\users\{username}\OneDrive - Company123\Desktop

How can I search in both locations in these procedures. The files will only be in one or the other.

Here is my entire Module1 code:

Option Explicit

#If VBA7 Then
    
    Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" _
            (ByVal hwnd As LongPtr, _
            lpdwProcessId As LongPtr) As Long
    
    Private Declare PtrSafe Function AttachThreadInput Lib "user32" _
            (ByVal idAttach As Long, _
            ByVal idAttachTo As Long, _
    ByVal fAttach As Long) As Long                'all Long because thread IDs are still 32 bits wide in 64-bit Windows
    
    Private Declare PtrSafe Function GetForegroundWindow Lib "user32" _
            () As LongPtr
    
    Private Declare PtrSafe Function SetForegroundWindow Lib "user32" _
            (ByVal hwnd As LongPtr) As Long
    
    Private Declare PtrSafe Function IsIconic Lib "user32" _
            (ByVal hwnd As LongPtr) As Long
    
    Private Declare PtrSafe Function ShowWindow Lib "user32" _
            (ByVal hwnd As LongPtr, _
            ByVal nCmdShow As Long) As Long
    
#Else
    
    Private Declare Function GetWindowThreadProcessId Lib "user32" _
            (ByVal hwnd As Long, _
            lpdwProcessId As Long) As Long
    
    Private Declare Function AttachThreadInput Lib "user32" _
            (ByVal idAttach As Long, _
            ByVal idAttachTo As Long, _
            ByVal fAttach As Long) As Long
    
    Private Declare Function GetForegroundWindow Lib "user32" _
            () As Long
    
    Private Declare Function SetForegroundWindow Lib "user32" _
            (ByVal hwnd As Long) As Long
    
    Private Declare Function IsIconic Lib "user32" _
            (ByVal hwnd As Long) As Long
    
    Private Declare Function ShowWindow Lib "user32" _
            (ByVal hwnd As Long, _
            ByVal nCmdShow As Long) As Long
    
#End If

Private Const SW_SHOW = 5
Private Const SW_RESTORE = 9

Sub GetURL()

    Dim NewURL As String
    Dim FollowURL As String

    NewURL = ThisWorkbook.Sheets("Category Review").Range("AP107").Value

    CheckforDuplicateDownloadFile
    
    ThisWorkbook.FollowHyperlink NewURL
    
    Dim t As Single
    t = Timer
    Do: DoEvents: Loop Until Timer - t >= 10 '<===  wait 1 second (change delay as required.)

    Call BringWindowToFront(Application.hwnd)
    
    'AppActivate "Category Review Builder"

    WaitForFileDownload

    BuildMyCategoryReview

End Sub

Private Function BringWindowToFront _
        (ByVal hwnd As Long) As Boolean

    Dim ThreadID1 As Long
    Dim ThreadID2 As Long
    Dim nRet   As Long

    On Error Resume Next
    
    ' Nothing to do if already in foreground.
    If hwnd = GetForegroundWindow() Then
        BringWindowToFront = True
    Else
        
        'First need to get the thread responsible for this window,
        'and the thread for the foreground window.
        ThreadID1 = _
                    GetWindowThreadProcessId(GetForegroundWindow, ByVal 0&)
        ThreadID2 = _
                    GetWindowThreadProcessId(hwnd, ByVal 0&)
        
        'By sharing input state, threads share their concept of
        'the active window.
        Call AttachThreadInput(ThreadID1, ThreadID2, True)
        nRet = SetForegroundWindow(hwnd)
        
        'Restore and repaint.
        If IsIconic(hwnd) Then
            Call ShowWindow(hwnd, SW_RESTORE)
        Else
            Call ShowWindow(hwnd, SW_SHOW)
        End If
        
        'BringWindowToFront returns TRUE if success.
        BringWindowToFront = CBool(nRet)
        
    End If
End Function

Sub CheckforDuplicateDownloadFile()

    Dim MyPath As String
    Dim MyNewPath As String
    Dim MyFileTxt As String
    Dim MyfilePPT As String
    Dim MypptStrFile As String
    Dim MyNewFileName As String
    Dim FilePath As String
    Dim MyReportName As String
    Dim MyNewReportName As String
    Dim TextFile As Integer
    Dim FileContent As String

    WriteTextFile
    
    MyPath = Environ("USERPROFILE") & "\Downloads\"
    MyNewPath = Environ("USERPROFILE") & "\Downloads\Category Review Downloaded Backup Files\" 'Modify as needed
    MyFileTxt = "Category Review BUCategory.txt"
    MyReportName = "Category Review BUCategory.txt"
    MyNewReportName = Left(MyReportName, Len(MyReportName) - 1) & "m"
    
    
    MyNewFileName = ThisWorkbook.Sheets("Category Review").Range("AP122").Value
    
    FilePath = GetDownloadPath & "\" & MyNewFileName
    
    MypptStrFile = Trim(GetDownloadPath) & "\" & Trim(MyNewFileName)
    MypptStrFile = Trim(Replace(MypptStrFile, vbCr, ""))
    MyfilePPT = MypptStrFile
    
    If Not Dir(MyPath & MyFileTxt, vbDirectory) = vbNullString Then
        'delete txt file if exists
        Kill MyPath & MyFileTxt
    End If
    
    If Not Dir(MyfilePPT, vbDirectory) = vbNullString Then
        'prompt the user if file PPTX exixts
        If MsgBox("The following file already exists in your downloads folder:" & vbNewLine & vbNewLine & MyNewFileName & vbNewLine & vbNewLine & "Do you want to make a backup copy?" & Chr(10) _
         & Chr(10) & "If you click NO it will be deleted!", vbYesNo + vbQuestion, "WARNING: Before you continue") = vbYes Then
            'if YES is pressed, create new folder if it doesn't exists
            With CreateObject("Scripting.FileSystemObject")
                If Not .FolderExists(MyNewPath) Then .CreateFolder MyNewPath
                
                .CopyFile MyfilePPT, MyNewPath & MyNewFileName, True 'Copy file to new folder, overwrite if exists, then delete it
                Kill MyfilePPT
            End With
            
        Else
            'if NO is pressed, delete PPTX file
            Kill MyfilePPT
        End If
    End If
    
End Sub

Sub WaitForFileDownload()
    Dim strFile     As String
    Dim blnContinue As Boolean
    Dim dteStart    As Date
    Dim MyNewFileName As String
    Dim FilePath As String

    Const lngWait   As Long = 60                  'wait in seconds

    MyNewFileName = ThisWorkbook.Sheets("Category Review").Range("AP122").Value
    
    FilePath = GetDownloadPath & "\" & MyNewFileName
    
    dteStart = Now                                'log start time
    
    Do
        blnContinue = CBool(Len(Dir(FilePath)))   'check if the file exists
    Loop Until blnContinue Or Now > dteStart + TimeSerial(0, 0, lngWait) 'exit when the file is found or the timer has elapsed
    
    If blnContinue Then
        'do what you want to do
        'MsgBox "continue"
    Else
        'it isn't downloading
        MsgBox "Can't download file"
    End If
    
End Sub

Sub BuildMyCategoryReview()

    Dim NewPPTFileName As String
    Dim PPTemplatestrName As String
    Dim PPApp  As Object, PPPrsn As Object, PPSlide As Object
    Dim PPShape As Object
    Dim URL1   As String
    Dim URL2   As String

    CheckforDesktopDuplicateFile
    
    NewPPTFileName = ThisWorkbook.Sheets("Category Review").Range("AP122").Value
    
    'Change this to the relevant file
    PPTemplatestrName = GetDesktopPath & "Category Review Template.pptm"
    
    'Establish an PowerPoint application object
    On Error Resume Next
    Set PPApp = GetObject(, "PowerPoint.Application")
    
    If Err.Number <> 0 Then
        Set PPApp = CreateObject("PowerPoint.Application")
    End If
    Err.Clear
    On Error GoTo 0
    
    PPApp.Visible = True
    
    'Open the relevant powerpoint file
    Set PPPrsn = PPApp.Presentations.Open(PPTemplatestrName)
    'PPPrsn.ActiveWindow.WindowState = ppWindowMaximized
    
    'Change this to the relevant slide which has the shape
    Set PPSlide = PPPrsn.Slides(16)
    AppActivate "Category Review Builder"
    'Change this to the relevant shape
    Set PPShape = PPSlide.Shapes("ADHocItemRanking")
    'Write to the shape
    PPShape.TextFrame.TextRange.Text = ThisWorkbook.Sheets("Category Review").Range("AP110").Value
    
    'Change this to the relevant slide which has the shape
    Set PPSlide = PPPrsn.Slides(16)
    AppActivate "Category Review Builder"
    'Change this to the relevant shape
    Set PPShape = PPSlide.Shapes("ADHocEfficientAssortment")
    'Write to the shape
    PPShape.TextFrame.TextRange.Text = ThisWorkbook.Sheets("Category Review").Range("AP113").Value
    
    'Change this to the relevant slide which has the shape
    Set PPSlide = PPPrsn.Slides(21)
    AppActivate "Category Review Builder"
    'Change this to the relevant shape
    Set PPShape = PPSlide.Shapes("ConsumerProfile")
    'Write to the shape
    PPShape.TextFrame.TextRange.Text = ThisWorkbook.Sheets("Category Review").Range("AP116").Value
    
    'Change this to the relevant slide which has the shape
    Set PPSlide = PPPrsn.Slides(21)
    AppActivate "Category Review Builder"
    'Change this to the relevant shape
    Set PPShape = PPSlide.Shapes("CompetitorByChannel")
    'Write to the shape
    PPShape.TextFrame.TextRange.Text = ThisWorkbook.Sheets("Category Review").Range("AP119").Value
    
    'Change this to the relevant slide which has the shape
    Set PPSlide = PPPrsn.Slides(2)
    AppActivate "Category Review Builder"
    'Change this to the relevant shape
    Set PPShape = PPSlide.Shapes("Category Manager")
    'Write to the shape
    PPShape.TextFrame.TextRange.Text = "CATEGORY MANAGER: " & ThisWorkbook.Sheets("Category Review").Range("AP131").Value
    
    'Change this to the relevant slide which has the shape
    Set PPSlide = PPPrsn.Slides(2)
    AppActivate "Category Review Builder"
    'Change this to the relevant shape
    Set PPShape = PPSlide.Shapes("Category Role")
    'Write to the shape
    PPShape.TextFrame.TextRange.Text = "CATEGORY ROLE: " & ThisWorkbook.Sheets("Category Review").Range("AP134").Value
    
    'Change this to the relevant slide which has the shape
    Set PPSlide = PPPrsn.Slides(2)
    AppActivate "Category Review Builder"
    'Change this to the relevant shape
    Set PPShape = PPSlide.Shapes("Category Class")
    'Write to the shape
    PPShape.TextFrame.TextRange.Text = "CATEGORY CLASS: " & ThisWorkbook.Sheets("Category Review").Range("AP137").Value
    
    'Change this to the relevant slide which has the shape
    Set PPSlide = PPPrsn.Slides(2)
    AppActivate "Category Review Builder"
    'Change this to the relevant shape
    Set PPShape = PPSlide.Shapes("Category Strategy")
    'Write to the shape
    PPShape.TextFrame.TextRange.Text = "CATEGORY STRATEGY: " & ThisWorkbook.Sheets("Category Review").Range("AP140").Value
    
    'Change this to the relevant slide which has the shape
    Set PPSlide = PPPrsn.Slides(2)
    AppActivate "Category Review Builder"
    'Change this to the relevant shape
    Set PPShape = PPSlide.Shapes("Definition")
    'Write to the shape
    PPShape.TextFrame.TextRange.Text = "DEFINITION: " & ThisWorkbook.Sheets("Category Review").Range("AP156").Value
    
    Application.EnableEvents = False
    PPApp.Run "Category Review Template.pptm!Module1.BuildPPT"
    Application.EnableEvents = True
    Application.EnableEvents = False
    PPApp.Run "Category Review Template.pptm!Module1.AddURLs"
    Application.EnableEvents = True
    
    AppActivate "Category Review Builder"
    
    NewPPTFileName = Left(NewPPTFileName, Len(NewPPTFileName) - 5)
    
    ThatWasEasy
    
    AppActivate NewPPTFileName
    
End Sub

Sub CheckforDesktopDuplicateFile()

    Dim MyPath As String
    Dim MyNewPath As String
    Dim MyFileTxt As String
    Dim MyfilePPT As String
    Dim MypptStrFile As String
    Dim MyNewFileName As String
    Dim FilePath As String
    Dim MyReportName As String
    Dim MyNewReportName As String
    Dim TextFile As Integer
    Dim FileContent As String

    WriteTextFile
    
    MyPath = Environ("USERPROFILE") & "\Desktop\"
    MyNewPath = Environ("USERPROFILE") & "\Desktop\Category Review Backup Files\" 'Modify as needed
    MyFileTxt = "Category Review BUCategory.txt"
    
    
    'File Path & Name of Text File
    FilePath = GetDownloadPath & "\" & "Category Review BUCategory.txt"
    
    'Determine the next file number available for use by the FileOpen function
    TextFile = FreeFile
    
    'Open the text file
    Open FilePath For Input As TextFile
    
    'Store file content inside a variable
    FileContent = Input(LOF(TextFile), TextFile)
    
    'Close Text File
    Close TextFile
    
    MyNewReportName = Left(FileContent, Len(FileContent) - 1) & "m"
    
    MyNewFileName = ThisWorkbook.Sheets("Category Review").Range("AP122").Value
    
    FilePath = GetDesktopPath & MyNewReportName
    
    MypptStrFile = Trim(GetDesktopPath) & Trim(MyNewReportName)
    MypptStrFile = Trim(Replace(MypptStrFile, vbCr, ""))
    MyfilePPT = MypptStrFile
    
    If Not Dir(MyPath & MyFileTxt, vbDirectory) = vbNullString Then
        'delete txt file if exists
        Kill MyPath & MyFileTxt
    End If
    
    If Not Dir(MyfilePPT, vbDirectory) = vbNullString Then
        'prompt the user if file PPTX exixts
        Select Case MsgBox("The following file already exists on your Desktop:" & vbNewLine & vbNewLine & MyNewFileName & vbNewLine & vbNewLine & "Do you want to make a backup copy? This will overwrite any existing file in the Backup folder" & Chr(10) _
             & Chr(10) & "If you click NO it will be deleted!", vbYesNoCancel + vbExclamation, "WARNING: Before you continue")
            Case vbYes
                'if YES is pressed, create new folder if it doesn't exists
                With CreateObject("Scripting.FileSystemObject")
                    If Not .FolderExists(MyNewPath) Then .CreateFolder MyNewPath
                    
                    .CopyFile MyfilePPT, MyNewPath & MyNewFileName, True 'Copy file to new folder, overwrite if exists, then delete it
                    Kill MyfilePPT
                End With
                
            Case vbNo
                'if NO is pressed, delete PPTX file
                Kill MyfilePPT
            Case vbCancel
                'if CANCEL is pressed, stop Code
                Exit Sub
                
        End Select
        
    End If
    
End Sub

'Function IsFileOpen(fileName As String)
'
'    Dim fileNum As Integer
'    Dim errNum As Integer
'
'    'Allow all errors to happen
'    On Error Resume Next
'    fileNum = FreeFile()
'
'    'Try to open and close the file for input.
'    'Errors mean the file is already open
'    Open fileName For Input Lock Read As #fileNum
'    Close fileNum
'
'    'Get the error number
'    errNum = Err
'
'    'Do not allow errors to happen
'    On Error GoTo 0
'
'    'Check the Error Number
'    Select Case errNum
'
'        'errNum = 0 means no errors, therefore file closed
'        Case 0
'            IsFileOpen = False
'
'            'errNum = 70 means the file is already open
'        Case 70
'            IsFileOpen = True
'
'            'Something else went wrong
'        Case Else
'            IsFileOpen = errNum
'
'    End Select
'
'End Function
'
'Sub CheckIfFileOpen()
'
'    Dim fileName As String
'    fileName = "C:\Users\marks\Documents\Already Open.xlsx"
'
'    'Call function to check if the file is open
'    If IsFileOpen(fileName) = False Then
'
'        'Insert actions to be performed on the closed file
'
'    Else
'
'        'The file is open or another error occurred
'        MsgBox fileName & " is already open."
'
'    End If
'
'End Sub

Sub WriteTextFile()

    Dim strFile_Path As String
    Dim FilePath As String

    FilePath = GetDownloadPath & "\" & "Category Review BUCategory.txt"
    
    If Dir(FilePath) <> "" Then
        
        Kill FilePath
        
        strFile_Path = GetDownloadPath & "\" & "Category Review BUCategory.txt"
        Open strFile_Path For Output As #1
        Print #1, ThisWorkbook.Sheets("Category Review").Range("AP122").Value;
        Close #1
        
    Else
        strFile_Path = GetDownloadPath & "\" & "Category Review BUCategory.txt"
        Open strFile_Path For Output As #1
        Print #1, ThisWorkbook.Sheets("Category Review").Range("AP122").Value;
        Close #1
    End If
End Sub

Sub ThatWasEasy()

    MsgBox "Your new Category Review has been built" & vbNewLine & vbNewLine & "Click OK to display your Category Review.", vbInformation, "Congratulations!"
    
End Sub

Sub GoToLinks()

    Application.Goto Reference:="R100C26"
    ActiveWindow.ScrollRow = ActiveCell.Row
    ActiveWindow.ScrollColumn = ActiveCell.Column
    
End Sub

Sub GoToHome()

    Application.Goto Reference:="R1C1"
    
End Sub

Sub GoToEnd()

    Application.Goto Reference:="R100C37"
    ActiveWindow.ScrollRow = ActiveCell.Row
    ActiveWindow.ScrollColumn = ActiveCell.Column
    
End Sub

Sub ReCalculate()

    Calculate
    
End Sub

Sub AdjustPPTSettings()

    Sheets("Adjust PPT Settings").Select
    Range("A1").Select
End Sub

Sub GoToCategoryReview()

    Sheets("Category Review").Select
    Range("A1").Select
    
End Sub

Sub GoToInstructions()

    Sheets("Instructions").Select
    Range("A1").Select
    
End Sub


Sub GoToRequirements()

    Sheets("Requirements").Select
    Range("A1").Select
    
End Sub

Function GetDownloadPath() As String

    GetDownloadPath = Environ("USERPROFILE") & "\Downloads"
    
End Function

Function GetDesktopPath()

    Dim WSHShell    As Object

    Set WSHShell = CreateObject("Wscript.Shell")
    GetDesktopPath = WSHShell.SpecialFolders(4)
    If Right(GetDesktopPath, 1) <> "\" Then
        GetDesktopPath = GetDesktopPath & "\"
    End If
    
End Function

'Sub GetURL()
'
'    Dim NewURL As String
'    Dim FollowURL As String
'
'    NewURL = ThisWorkbook.Sheets("Category Review").Range("AP107").Value
'
'    CheckforDuplicateDownloadFile
'
'    ThisWorkbook.FollowHyperlink NewURL
'
'    'Sheets("Instructions").Select
'
'    AppActivate "Category Review Builder"
'
'    WaitForFileDownload
'
'    BuildMyCategoryReview
'
'End Sub

 

[Misca]

I wrote a little UDF using the DIR function:

Function MyFile(File1 As String, File2 As String) As String

If Len(Dir(File1)) = 0 Then
'File1 not found
    If Len(Dir(File2)) = 0 Then
    'File2 not found
        MyFile = ""
    Else
        MyFile = File2
    End If
Else
    MyFile = File1
End If

End Function

The function uses two (full) filepaths as parameters. You'll get the name of the first file that is found or a blank ("") if DIR finds nothing.

 

[gmooney]

I wrote a little UDF using the DIR function:

Function MyFile(File1 As String, File2 As String) As String

If Len(Dir(File1)) = 0 Then
'File1 not found
    If Len(Dir(File2)) = 0 Then
    'File2 not found
        MyFile = ""
    Else
        MyFile = File2
    End If
Else
    MyFile = File1
End If

End Function

The function uses two (full) filepaths as parameters. You'll get the name of the first file that is found or a blank ("") if DIR finds nothing.

@Misca where in my code would I add this and how would this code get called upon?

 

[johnnyL]

@gmooney Was your intention for CheckforDuplicateDownloadFile & CheckforDesktopDuplicateFile both do the same thing with the one exception of checking 2 different locations?

 

[gmooney]

@gmooney Was your intention for CheckforDuplicateDownloadFile & CheckforDesktopDuplicateFile both do the same thing with the one exception of checking 2 different locations?

Yes

 

[johnnyL]

ok

 

[Misca]

Copy the function to your module and call it whenever you're not sure which file exists. Just make sure to include not only the actual file name but the whole path as well.

The following code looks for the file "Category Review BUCategory.txt" in two folders and returns the first one it finds:

Sub Example()

Dim UserName As String
Dim Path1 As String
Dim Path2 As String
Dim FileName As String

UserName = Environ("UserName")

Path1 = PathFix("C:\users\" & UserName & "\OneDrive - Company123\Downloads")
Path2 = PathFix("C:\users\" & UserName & "\OneDrive - Company123\Desktop")
FileName = "Category Review BUCategory.txt"

MsgBox MyFile(Path1 & FileName, Path2 & FileName)

End Sub

Function PathFix(Path As String) As String

Dim Separator As String

Separator = Application.PathSeparator

If Right(Path, 1) = Separator Then
'Path ends with the path separator:
    PathFix = Path
Else
'Adds the missing path separator to the path:
    PathFix = Path & Separator
End If

End Function

As you can see the code uses the function MyFile but I didn't include it in here. Make sure to copy it to the end if you test how it works. Also, make sure the two paths are correct.

 

[johnnyL]

Another question @gmooney Do you have any other code in the workbook that uses the code from the module that you posted?

 

[gmooney]

Another question @gmooney Do you have any other code in the workbook that uses the code from the module that you posted?

@johnnyL Not in other modules. I do have a workbook open in ThisWorkbook that basically starts the start page to open the file on.

 

[johnnyL]

@gmooney Was your intention for CheckforDuplicateDownloadFile & CheckforDesktopDuplicateFile both do the same thing with the one exception of checking 2 different locations?

Are You sure, that is your intention? The reason why I am asking is because the two routines do not do exactly the same things outside of checking different locations. So if you had to choose which routine is the one that does what you want to happen, which one would it be?