AppActivate After opening Web Brower

gmooney

gmooney

Active Member
Joined
Oct 21, 2004
Messages
257
Office Version
  1. 365
Platform
  1. Windows
Hi,

I have the following code that essentially looks for a downloaded file before launching the URL and automatically downloading a file.

I want the Excel file to return to focus but this code is not and it is staying on the web browser, thus I have to click on Excel from the taskbar. Any ideas how to get Excel back to be displayed?

VBA Code: 
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
 
Sort by date Sort by votes
Jaafar Tribak said:
Try this :
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 Test()

    With CreateObject("InternetExplorer.Application")
        .Visible = True
        .navigate "http://www.mrexcel.com"
        Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
    End With
 
    BringWindowToFront Application.hwnd
 
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
Click to expand...
@Jaafar Tribak This seems to work as it launches MrExcel and then returns me to the the VBA window.

Now with my original code where do I need to place this code back into my file, what module and when do I call the Sub Test?
 
Upvote 0
Are CheckforDuplicateDownloadFile, WaitForFileDownload and BuildMyCategoryReview macros ?
If so, where are they defined ? are they located in some other standard modules or in the same module as where GetURL is defined ?
 
Upvote 0
Jaafar Tribak said:
Are CheckforDuplicateDownloadFile, WaitForFileDownload and BuildMyCategoryReview macros ?
If so, where are they defined ? are they located in some standard modules ?
Click to expand...
Yes all 3 of them are simple Subs in the same Module1. CheckForDuplicates essentially is checking to see if the new downloaded file already exist and if so it gives the user the option to save backup or delete it. WiatForFileDownload is another Sub in Module1 that waits until the web browser is launched and the file downloaded. I had to add this is some users have to login into the website after it launches the URL and a standard timer of waiting would not work. BuildMyCategoryReview is the final Sub in Module1 that takes the new downloaded file and merges it with another file that is on the user's desktop.

Here is my complete Module1 code: GerURL is what kicks off this whole sequence of events.

VBA Code: 
Option Explicit

Sub GetURL()

    Dim NewURL As String
    Dim FollowURL As String

    NewURL = ThisWorkbook.Sheets("Category Review").Range("AP107").Value
   
    CheckforDuplicateDownloadFile
   
    ThisWorkbook.FollowHyperlink NewURL
   
    WaitForFileDownload
   
    BuildMyCategoryReview
   
End Sub

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
 
Upvote 0
Ok- See if this works for you :
To be placed in the same module (Module1) where GetURL is located : (Obviously, you will need to add your other macros as well)
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
   
    With CreateObject("InternetExplorer.Application")
        .Visible = True
        .navigate NewURL
        Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
    End With
   
    Call BringWindowToFront(Application.hwnd)
   
    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
 
Upvote 0
Jaafar Tribak said:
Ok- See if this works for you :
To be placed in the same module (Module1) where GetURL is located : (Obviously, you will need to add your other macros as well)
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
  
    With CreateObject("InternetExplorer.Application")
        .Visible = True
        .navigate NewURL
        Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
    End With
  
    Call BringWindowToFront(Application.hwnd)
  
    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
Click to expand...
I went back to having the compile error. I think you might have responded before you saw my entire Module1 code? Can you integrate your code into that?
 
Upvote 0
gmooney said:
I went back to having the compile error. I think you might have responded before you saw my entire Module1 code? Can you integrate your code into that?
Click to expand...
Which compile error are you getting this time ? and on which line ?
 
Upvote 0
Jaafar Tribak said:
Which compile error are you getting this time ? and on which line ?
Click to expand...
It was the same as before? I think when I took your latest code and pasted into the beginning of my Module1 code I might have overwritten some other Subs. I just did it again and didn't get a compile error but I no longer is the Sub Test to run?
 
Upvote 0
Try this where both codes are now integrated and run the GetURL macro:
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
   
    With CreateObject("InternetExplorer.Application")
        .Visible = True
        .navigate NewURL
        Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
    End With
   
    Call BringWindowToFront(Application.hwnd)
   
    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
 
Upvote 0
Jaafar Tribak said:
Which compile error are you getting this time ? and on which line ?
Click to expand...
Never mind. I failed to copy over the Sub Test. Okay so now this works as far as the GetURL doing the MrExcel.com thing but I need to go back and put my original Get URL code into it. Here it that code commented out. Will this work now?
VBA Code: 
'Sub GetURL()
'
'    Dim NewURL As String
'    Dim FollowURL As String
'
'    NewURL = ThisWorkbook.Sheets("Category Review").Range("AP107").Value
'
'    CheckforDuplicateDownloadFile
'
'    ThisWorkbook.FollowHyperlink NewURL
'
'    WaitForFileDownload
'
'    BuildMyCategoryReview
'
'End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

gmooney
  • Solved
Macro to Launch URL
Replies
1
Views
1K
EFANYoutube
E
gmooney
  • Question Question
Check for file needed that will be in 1 of 2 locations
2
Replies
16
Views
2K
johnnyL
J

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