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