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

gmooney

gmooney

Active Member
Joined
Oct 21, 2004
Messages
254
Office Version
  1. 365
Platform
  1. Windows
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:

VBA 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
 
Sort by date Sort by votes
johnnyL said:
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?
Click to expand...
Yes, what happens is the user runs the GetURL code and that checks to see if they had previously downloaded a PPT file which would be in one of the 2 downloads locations listed about, The OneDrive or Standard Downloads location. Then later in the code it checks to see if there is a PPT file on there desktop, which would have been previously saved to their desktop if the code ran completely before. Again, it needs to check the OneDrive Desktop and standard Desktop locations. I am doing this so that I can prompt the user with an option to save a backup copy of the file if it finds a previously downloaded PPT file or completely saved PPT file on their desktop.
 
Upvote 0

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
I understand that you now want 4 locations checked, I will cross that bridge later. I am referring to the two previous locations. Is there a reason that you don't want to check both of those two locations at the same time? Should both of those checked locations be handled the exact same way? Right now, I am leaning to make both of those checks perform what the CheckforDesktopDuplicateFile routine does with the exception of the location being checked of course. Is that acceptable? Please answer those questions.
 
Upvote 0
johnnyL said:
I understand that you now want 4 locations checked, I will cross that bridge later. I am referring to the two previous locations. Is there a reason that you don't want to check both of those two locations at the same time? Should both of those checked locations be handled the exact same way? Right now, I am leaning to make both of those checks perform what the CheckforDesktopDuplicateFile routine does with the exception of the location being checked of course. Is that acceptable? Please answer those questions.
Click to expand...
They need to be checked at different times in the code or at least I think they do; maybe they do not. The beginning of the code is downloading a PPT file and then it opens up a template.ppt file that should be on the desktop, and then finishes all the merging and re-arranging of slides of the 2 PPT files to create the newly named PPT file on the desktop. Because the user might not care about saving an already downloaded file but they do care about the newly named PPT file that is on their desktop I choose to do both of the dialog prompts in 2 different sets of code so they had flexibility of how the wanted to either delete or create backup of either file. Make sense?
 
Upvote 0
Ok I have shortened your code by rougly 50% in the following version. Keep in mind that you said both of the initial two checks should do the exact same thing with the one exception of the location being checked. I have kept the two checks separate as you indicated. I put all of the 'unneeded' code that I found/produced at the bottom of the script. If you run this version without errors, you can delete all of those commented out lines at the bottom of the code, I have left them in there in case you want to reenable them/copy them back, but if you have no issues, you can delete them, thus yielding a major shrinkage in the code size.

Let us know if the results are consistant with the checking for duplicate file in the initial two locations.

VBA 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
'
    Dim MyPath          As String
'
    Private Const MyFileTxt As String = "Category Review BUCategory.txt"

    Private Const SW_RESTORE = 9
    Private Const SW_SHOW = 5
   


Sub GetURL()
'
    Dim t           As Single
    Dim NewURL      As String
'
    MyPath = Environ("USERPROFILE") & "\Downloads\"
    Call CheckforDuplicateFile                                                          ' Check the downloads folder for duplicate file
'
    NewURL = ThisWorkbook.Sheets("Category Review").Range("AP107").Value
    ThisWorkbook.FollowHyperlink NewURL
'
    t = Timer
'
    Do
        DoEvents
    Loop Until Timer - t >= 10  '<===  wait 10 seconds (change delay as required.)
'
    Call BringWindowToFront(Application.hwnd)
'
    Call WaitForFileDownload
'
    Call BuildMyCategoryReview
End Sub


Private Function BringWindowToFront(ByVal hwnd As Long) As Boolean
'
    Dim nRet        As Long
    Dim ThreadID1   As Long
    Dim ThreadID2   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 CheckforDuplicateFile()
'
    Dim TextFile        As Integer
    Dim FileContent     As String
    Dim FilePath        As String
    Dim MyfilePPT       As String
    Dim MyNewFileName   As String
    Dim MyNewPath       As String
    Dim MyNewReportName As String
    Dim MypptStrFile    As String
    Dim MyReportName    As String
'
    Call WriteTextFile
'
    MyNewPath = MyPath & "Category Review Backup Files\"           ' Modify as needed
'
    FilePath = Environ("USERPROFILE") & "\Downloads\" & "Category Review BUCategory.txt"                    ' File Path & Name of Text File
    TextFile = FreeFile                                                            ' Determine the next file number available for use by the FileOpen function
'
    Open FilePath For Input As TextFile                                                     ' Open the text file
    FileContent = Input(LOF(TextFile), TextFile)                                            ' Store file content inside a variable
    Close TextFile                                                                          ' Close Text File
'
    MyNewReportName = Trim(Left(FileContent, Len(FileContent) - 1) & "m")
      MyNewFileName = ThisWorkbook.Sheets("Category Review").Range("AP122").Value
'
       MypptStrFile = MyPath & MyNewReportName
       MypptStrFile = Trim(Replace(MypptStrFile, vbCr, ""))
          MyfilePPT = MypptStrFile
'
    If Not Dir(MyPath & MyFileTxt, vbDirectory) = vbNullString Then Kill MyPath & MyFileTxt ' delete txt file if exists
'
    If Not Dir(MyfilePPT, vbDirectory) = vbNullString Then                                  ' prompt the user if file PPTX exixts
        Select Case MsgBox("The following file already exists:" & vbNewLine & vbNewLine & MyNewFileName & vbNewLine _
                & vbNewLine & "Do you want to make a backup copy? This will overwrite the 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
                With CreateObject("Scripting.FileSystemObject")                         ' if YES is pressed, create new folder if it doesn't exists
                    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
                Kill MyfilePPT                                                          ' if NO is pressed, delete PPTX file
            Case vbCancel
                Exit Sub                                                                ' if CANCEL is pressed, stop Code
        End Select
    End If
End Sub


Sub WriteTextFile()
'
    Dim FilePath        As String
'
    FilePath = Environ("USERPROFILE") & "\Downloads\" & "Category Review BUCategory.txt"
'
    If Dir(FilePath) <> "" Then Kill FilePath
'
    Open FilePath For Output As #1
    Print #1, ThisWorkbook.Sheets("Category Review").Range("AP122").Value;
    Close #1
End Sub


Sub WaitForFileDownload()
'
    Dim blnContinue     As Boolean
    Dim dteStart        As Date
    Dim FilePath        As String
    Dim MyNewFileName   As String
'
    Const lngWait       As Long = 60                                                ' wait in seconds
'
         dteStart = Now                                                             ' log start time
    MyNewFileName = ThisWorkbook.Sheets("Category Review").Range("AP122").Value
         FilePath = Environ("USERPROFILE") & "\Downloads\" & MyNewFileName
'
    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 PPApp               As Object, PPPrsn As Object, PPShape As Object, PPSlide As Object
    Dim NewPPTFileName      As String
    Dim PPTemplatestrName   As String
'
''    Call CheckforDesktopDuplicateFile
    MyPath = Environ("USERPROFILE") & "\Desktop\"
    Call CheckforDuplicateFile                                                          ' Check the desktop folder for duplicate file
'
    NewPPTFileName = ThisWorkbook.Sheets("Category Review").Range("AP122").Value
'
    PPTemplatestrName = Environ("USERPROFILE") & "\Desktop\" & "Category Review Template.pptm"      ' <--- Change this to the relevant file
'
    On Error Resume Next
    Set PPApp = GetObject(, "PowerPoint.Application")                                   ' Establish a PowerPoint application object
'
    If Err.Number <> 0 Then
        Set PPApp = CreateObject("PowerPoint.Application")
    End If
    Err.Clear
    On Error GoTo 0
'
    PPApp.Visible = True
'
    Set PPPrsn = PPApp.Presentations.Open(PPTemplatestrName)                            ' Open the relevant powerpoint file
    'PPPrsn.ActiveWindow.WindowState = ppWindowMaximized
'
'
'
    Set PPSlide = PPPrsn.Slides(16)                                                     ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("ADHocItemRanking")                                    ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = ThisWorkbook.Sheets("Category Review").Range("AP110").Value  ' Write to the shape
'
'
'
    Set PPSlide = PPPrsn.Slides(16)                                                     ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("ADHocEfficientAssortment")                            ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = ThisWorkbook.Sheets("Category Review").Range("AP113").Value  'Write to the shape
'
'
'
    Set PPSlide = PPPrsn.Slides(21)                                                     ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("ConsumerProfile")                                     ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = ThisWorkbook.Sheets("Category Review").Range("AP116").Value  'Write to the shape
'
'
'
    Set PPSlide = PPPrsn.Slides(21)                                                     ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("CompetitorByChannel")                                 ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = ThisWorkbook.Sheets("Category Review").Range("AP119").Value  ' Write to the shape
'
'
'
    Set PPSlide = PPPrsn.Slides(2)                                                      ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("Category Manager")                                    ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = "CATEGORY MANAGER: " & ThisWorkbook.Sheets("Category Review").Range("AP131").Value   'Write to the shape
'
'
'
    Set PPSlide = PPPrsn.Slides(2)                                                      ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("Category Role")                                       ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = "CATEGORY ROLE: " & ThisWorkbook.Sheets("Category Review").Range("AP134").Value  ' Write to the shape
'
'
'
    Set PPSlide = PPPrsn.Slides(2)                                                      ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("Category Class")                                      ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = "CATEGORY CLASS: " & ThisWorkbook.Sheets("Category Review").Range("AP137").Value ' Write to the shape
'
'
'
    Set PPSlide = PPPrsn.Slides(2)                                                      ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("Category Strategy")                                   ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = "CATEGORY STRATEGY: " & ThisWorkbook.Sheets("Category Review").Range("AP140").Value  ' Write to the shape
'
'
'
    Set PPSlide = PPPrsn.Slides(2)                                                      ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("Definition")                                          ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = "DEFINITION: " & ThisWorkbook.Sheets("Category Review").Range("AP156").Value ' Write to the shape
'
'
'
    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)
'
    MsgBox "Your new Category Review has been built" & vbNewLine & vbNewLine & "Click OK to display your Category Review.", vbInformation, "Congratulations!"
'
    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


''Sub CheckforDesktopDuplicateFile()
'
''    Dim TextFile        As Integer
''    Dim FileContent     As String
''    Dim FilePath        As String
''    Dim MyFileTxt       As String
''    Dim MyfilePPT       As String
''    Dim MyNewFileName   As String
''    Dim MyNewPath       As String
''    Dim MyNewReportName As String
''    Dim MyPath          As String
''    Dim MypptStrFile    As String
''    Dim MyReportName    As String
'
''    Call WriteTextFile
'
''    MyPath = Environ("USERPROFILE") & "\Desktop\"
''    MyNewPath = MyPath & "Category Review Backup Files\"           ' Modify as needed
'
''    FilePath = Environ("USERPROFILE") & "\Downloads\" & "Category Review BUCategory.txt"                    ' File Path & Name of Text File
''    TextFile = FreeFile                                                            ' Determine the next file number available for use by the FileOpen function
'
''    Open FilePath For Input As TextFile                                                     ' Open the text file
''    FileContent = Input(LOF(TextFile), TextFile)                                            ' Store file content inside a variable
''    Close TextFile                                                                          ' Close Text File
'
''    MyNewReportName = Trim(Left(FileContent, Len(FileContent) - 1) & "m")
''      MyNewFileName = ThisWorkbook.Sheets("Category Review").Range("AP122").Value
'
''       MypptStrFile = MyPath & MyNewReportName
''       MypptStrFile = Trim(Replace(MypptStrFile, vbCr, ""))
''          MyfilePPT = MypptStrFile
'
''    If Not Dir(MyPath & MyFileTxt, vbDirectory) = vbNullString Then Kill MyPath & MyFileTxt ' delete txt file if exists
'
''    If Not Dir(MyfilePPT, vbDirectory) = vbNullString Then                                  ' prompt the user if file PPTX exixts
''        Select Case MsgBox("The following file already exists:" & vbNewLine & vbNewLine & MyNewFileName & vbNewLine _
''                & vbNewLine & "Do you want to make a backup copy? This will overwrite the 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
''                With CreateObject("Scripting.FileSystemObject")                         ' if YES is pressed, create new folder if it doesn't exists
''                    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
''                Kill MyfilePPT                                                          ' if NO is pressed, delete PPTX file
''            Case vbCancel
''                Exit Sub                                                                ' if CANCEL is pressed, stop Code
''        End Select
''    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


''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


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


''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
 
Upvote 0
johnnyL said:
Ok I have shortened your code by rougly 50% in the following version. Keep in mind that you said both of the initial two checks should do the exact same thing with the one exception of the location being checked. I have kept the two checks separate as you indicated. I put all of the 'unneeded' code that I found/produced at the bottom of the script. If you run this version without errors, you can delete all of those commented out lines at the bottom of the code, I have left them in there in case you want to reenable them/copy them back, but if you have no issues, you can delete them, thus yielding a major shrinkage in the code size.

Let us know if the results are consistant with the checking for duplicate file in the initial two locations.

VBA 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
'
    Dim MyPath          As String
'
    Private Const MyFileTxt As String = "Category Review BUCategory.txt"

    Private Const SW_RESTORE = 9
    Private Const SW_SHOW = 5
  


Sub GetURL()
'
    Dim t           As Single
    Dim NewURL      As String
'
    MyPath = Environ("USERPROFILE") & "\Downloads\"
    Call CheckforDuplicateFile                                                          ' Check the downloads folder for duplicate file
'
    NewURL = ThisWorkbook.Sheets("Category Review").Range("AP107").Value
    ThisWorkbook.FollowHyperlink NewURL
'
    t = Timer
'
    Do
        DoEvents
    Loop Until Timer - t >= 10  '<===  wait 10 seconds (change delay as required.)
'
    Call BringWindowToFront(Application.hwnd)
'
    Call WaitForFileDownload
'
    Call BuildMyCategoryReview
End Sub


Private Function BringWindowToFront(ByVal hwnd As Long) As Boolean
'
    Dim nRet        As Long
    Dim ThreadID1   As Long
    Dim ThreadID2   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 CheckforDuplicateFile()
'
    Dim TextFile        As Integer
    Dim FileContent     As String
    Dim FilePath        As String
    Dim MyfilePPT       As String
    Dim MyNewFileName   As String
    Dim MyNewPath       As String
    Dim MyNewReportName As String
    Dim MypptStrFile    As String
    Dim MyReportName    As String
'
    Call WriteTextFile
'
    MyNewPath = MyPath & "Category Review Backup Files\"           ' Modify as needed
'
    FilePath = Environ("USERPROFILE") & "\Downloads\" & "Category Review BUCategory.txt"                    ' File Path & Name of Text File
    TextFile = FreeFile                                                            ' Determine the next file number available for use by the FileOpen function
'
    Open FilePath For Input As TextFile                                                     ' Open the text file
    FileContent = Input(LOF(TextFile), TextFile)                                            ' Store file content inside a variable
    Close TextFile                                                                          ' Close Text File
'
    MyNewReportName = Trim(Left(FileContent, Len(FileContent) - 1) & "m")
      MyNewFileName = ThisWorkbook.Sheets("Category Review").Range("AP122").Value
'
       MypptStrFile = MyPath & MyNewReportName
       MypptStrFile = Trim(Replace(MypptStrFile, vbCr, ""))
          MyfilePPT = MypptStrFile
'
    If Not Dir(MyPath & MyFileTxt, vbDirectory) = vbNullString Then Kill MyPath & MyFileTxt ' delete txt file if exists
'
    If Not Dir(MyfilePPT, vbDirectory) = vbNullString Then                                  ' prompt the user if file PPTX exixts
        Select Case MsgBox("The following file already exists:" & vbNewLine & vbNewLine & MyNewFileName & vbNewLine _
                & vbNewLine & "Do you want to make a backup copy? This will overwrite the 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
                With CreateObject("Scripting.FileSystemObject")                         ' if YES is pressed, create new folder if it doesn't exists
                    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
                Kill MyfilePPT                                                          ' if NO is pressed, delete PPTX file
            Case vbCancel
                Exit Sub                                                                ' if CANCEL is pressed, stop Code
        End Select
    End If
End Sub


Sub WriteTextFile()
'
    Dim FilePath        As String
'
    FilePath = Environ("USERPROFILE") & "\Downloads\" & "Category Review BUCategory.txt"
'
    If Dir(FilePath) <> "" Then Kill FilePath
'
    Open FilePath For Output As #1
    Print #1, ThisWorkbook.Sheets("Category Review").Range("AP122").Value;
    Close #1
End Sub


Sub WaitForFileDownload()
'
    Dim blnContinue     As Boolean
    Dim dteStart        As Date
    Dim FilePath        As String
    Dim MyNewFileName   As String
'
    Const lngWait       As Long = 60                                                ' wait in seconds
'
         dteStart = Now                                                             ' log start time
    MyNewFileName = ThisWorkbook.Sheets("Category Review").Range("AP122").Value
         FilePath = Environ("USERPROFILE") & "\Downloads\" & MyNewFileName
'
    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 PPApp               As Object, PPPrsn As Object, PPShape As Object, PPSlide As Object
    Dim NewPPTFileName      As String
    Dim PPTemplatestrName   As String
'
''    Call CheckforDesktopDuplicateFile
    MyPath = Environ("USERPROFILE") & "\Desktop\"
    Call CheckforDuplicateFile                                                          ' Check the desktop folder for duplicate file
'
    NewPPTFileName = ThisWorkbook.Sheets("Category Review").Range("AP122").Value
'
    PPTemplatestrName = Environ("USERPROFILE") & "\Desktop\" & "Category Review Template.pptm"      ' <--- Change this to the relevant file
'
    On Error Resume Next
    Set PPApp = GetObject(, "PowerPoint.Application")                                   ' Establish a PowerPoint application object
'
    If Err.Number <> 0 Then
        Set PPApp = CreateObject("PowerPoint.Application")
    End If
    Err.Clear
    On Error GoTo 0
'
    PPApp.Visible = True
'
    Set PPPrsn = PPApp.Presentations.Open(PPTemplatestrName)                            ' Open the relevant powerpoint file
    'PPPrsn.ActiveWindow.WindowState = ppWindowMaximized
'
'
'
    Set PPSlide = PPPrsn.Slides(16)                                                     ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("ADHocItemRanking")                                    ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = ThisWorkbook.Sheets("Category Review").Range("AP110").Value  ' Write to the shape
'
'
'
    Set PPSlide = PPPrsn.Slides(16)                                                     ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("ADHocEfficientAssortment")                            ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = ThisWorkbook.Sheets("Category Review").Range("AP113").Value  'Write to the shape
'
'
'
    Set PPSlide = PPPrsn.Slides(21)                                                     ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("ConsumerProfile")                                     ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = ThisWorkbook.Sheets("Category Review").Range("AP116").Value  'Write to the shape
'
'
'
    Set PPSlide = PPPrsn.Slides(21)                                                     ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("CompetitorByChannel")                                 ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = ThisWorkbook.Sheets("Category Review").Range("AP119").Value  ' Write to the shape
'
'
'
    Set PPSlide = PPPrsn.Slides(2)                                                      ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("Category Manager")                                    ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = "CATEGORY MANAGER: " & ThisWorkbook.Sheets("Category Review").Range("AP131").Value   'Write to the shape
'
'
'
    Set PPSlide = PPPrsn.Slides(2)                                                      ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("Category Role")                                       ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = "CATEGORY ROLE: " & ThisWorkbook.Sheets("Category Review").Range("AP134").Value  ' Write to the shape
'
'
'
    Set PPSlide = PPPrsn.Slides(2)                                                      ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("Category Class")                                      ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = "CATEGORY CLASS: " & ThisWorkbook.Sheets("Category Review").Range("AP137").Value ' Write to the shape
'
'
'
    Set PPSlide = PPPrsn.Slides(2)                                                      ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("Category Strategy")                                   ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = "CATEGORY STRATEGY: " & ThisWorkbook.Sheets("Category Review").Range("AP140").Value  ' Write to the shape
'
'
'
    Set PPSlide = PPPrsn.Slides(2)                                                      ' <--- Change this to the relevant slide which has the shape
    AppActivate "Category Review Builder"
    Set PPShape = PPSlide.Shapes("Definition")                                          ' <--- Change this to the relevant shape
    PPShape.TextFrame.TextRange.Text = "DEFINITION: " & ThisWorkbook.Sheets("Category Review").Range("AP156").Value ' Write to the shape
'
'
'
    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)
'
    MsgBox "Your new Category Review has been built" & vbNewLine & vbNewLine & "Click OK to display your Category Review.", vbInformation, "Congratulations!"
'
    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


''Sub CheckforDesktopDuplicateFile()
'
''    Dim TextFile        As Integer
''    Dim FileContent     As String
''    Dim FilePath        As String
''    Dim MyFileTxt       As String
''    Dim MyfilePPT       As String
''    Dim MyNewFileName   As String
''    Dim MyNewPath       As String
''    Dim MyNewReportName As String
''    Dim MyPath          As String
''    Dim MypptStrFile    As String
''    Dim MyReportName    As String
'
''    Call WriteTextFile
'
''    MyPath = Environ("USERPROFILE") & "\Desktop\"
''    MyNewPath = MyPath & "Category Review Backup Files\"           ' Modify as needed
'
''    FilePath = Environ("USERPROFILE") & "\Downloads\" & "Category Review BUCategory.txt"                    ' File Path & Name of Text File
''    TextFile = FreeFile                                                            ' Determine the next file number available for use by the FileOpen function
'
''    Open FilePath For Input As TextFile                                                     ' Open the text file
''    FileContent = Input(LOF(TextFile), TextFile)                                            ' Store file content inside a variable
''    Close TextFile                                                                          ' Close Text File
'
''    MyNewReportName = Trim(Left(FileContent, Len(FileContent) - 1) & "m")
''      MyNewFileName = ThisWorkbook.Sheets("Category Review").Range("AP122").Value
'
''       MypptStrFile = MyPath & MyNewReportName
''       MypptStrFile = Trim(Replace(MypptStrFile, vbCr, ""))
''          MyfilePPT = MypptStrFile
'
''    If Not Dir(MyPath & MyFileTxt, vbDirectory) = vbNullString Then Kill MyPath & MyFileTxt ' delete txt file if exists
'
''    If Not Dir(MyfilePPT, vbDirectory) = vbNullString Then                                  ' prompt the user if file PPTX exixts
''        Select Case MsgBox("The following file already exists:" & vbNewLine & vbNewLine & MyNewFileName & vbNewLine _
''                & vbNewLine & "Do you want to make a backup copy? This will overwrite the 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
''                With CreateObject("Scripting.FileSystemObject")                         ' if YES is pressed, create new folder if it doesn't exists
''                    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
''                Kill MyfilePPT                                                          ' if NO is pressed, delete PPTX file
''            Case vbCancel
''                Exit Sub                                                                ' if CANCEL is pressed, stop Code
''        End Select
''    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


''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


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


''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
Click to expand...
Hey @johnnyL thank you so much. Out to dinner but will check this out when I get home. I’ve learned so much with these last 2 post and I appreciate all the help from everyone. I will let you know what happens then.
 
Upvote 0
ok, let us know. If that approach works. I will incorporate the other two checks you requested.
 
Upvote 0
Misca said:
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:
VBA Code: 
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.
Click to expand...

How about just the following to do all of that? :

VBA Code: 
Sub Example()
'
    Dim Path1 As String
    Dim Path2 As String
    Dim FileName As String
'
    Path1 = Environ("UserProfile") & "\OneDrive - Company123\Downloads"
    Path2 = Environ("UserProfile") & "\OneDrive - Company123\Desktop"
    FileName = "Category Review BUCategory.txt"
'
    MsgBox MyFile(Path1 & FileName, Path2 & FileName)
'
End Sub


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 = "File1 and File2 not found"
        Else
            MyFile = "File2 found"
        End If
    Else
        MyFile = "File1 found"
    End If
End Function
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Accumulate Data from 10k+ Files. Very Slow. Issue with ActiveWorkbook.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
2
Replies
10
Views
987
NdNoviceHlp
NdNoviceHlp
gmooney
  • Solved
PPT Resuse Slides in VBA with dynamic file Name coming from Excel
Replies
4
Views
2K
gmooney
gmooney
gmooney
  • Solved
AppActivate After opening Web Brower
4 5 6
Replies
59
Views
8K
gmooney
gmooney
R
  • Question Question
VBA code - saving of data in different excel file.
Replies
0
Views
641
Radek1
R
T
  • Question Question
Excel to PowerPoint (VBA) (Referencing the right PowerPoint instance)
Replies
1
Views
5K
thesnowplow
T

Forum statistics

Threads
1,223,897
Messages
6,175,271
Members
452,628
Latest member
dd2

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top