Option Explicit
Global theAppPos As Double
Global theAppScreen As String
Sub GetURL()
Dim NewURL As String
Dim FollowURL As String
NewURL = ThisWorkbook.Sheets("Category Review").Range("AP107").Value
LookForDuplicateFile
ThisWorkbook.FollowHyperlink NewURL
End Sub
Sub LookForDuplicateFile()
Dim strFile_Path As String
Dim filepath As String
Dim pptStrFile As String
Dim NewFileName As String
Dim alterTime As Variant
NewFileName = ThisWorkbook.Sheets("Category Review").Range("AP122").Value
filepath = GetDownloadPath & "\" & NewFileName
pptStrFile = Trim(GetDownloadPath) & Trim(NewFileName)
pptStrFile = Trim(Replace(pptStrFile, vbCr, ""))
filepath = GetDownloadPath & "\" & "Category Review BUCategory.txt"
If Dir(filepath) <> "" Then
MsgBox "There is a file in your Downloads folder with the same" & vbNewLine & "file name as the one you are attempting to download" & vbNewLine & vbNewLine & "Do you want to overwrite it?", vbYesNo + vbQuestion, "Overwrite Existing File?"
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 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
NewPPTFileName = ThisWorkbook.Sheets("Category Review").Range("AP122").Value
PPTemplatestrName = GetDesktPPath & "Category Review Template.pptm"
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
Set PPPrsn = PPApp.Presentations.Open(PPTemplatestrName)
Set PPSlide = PPPrsn.Slides(16)
AppActivate "Category Review Links"
Set PPShape = PPSlide.Shapes("ADHocItemRanking")
PPShape.TextFrame.TextRange.Text = ThisWorkbook.Sheets("Category Review").Range("AP110").Value
Set PPSlide = PPPrsn.Slides(16)
AppActivate "Category Review Links"
Set PPShape = PPSlide.Shapes("ADHocEfficientAssortment")
PPShape.TextFrame.TextRange.Text = ThisWorkbook.Sheets("Category Review").Range("AP113").Value
Set PPSlide = PPPrsn.Slides(21)
AppActivate "Category Review Links"
Set PPShape = PPSlide.Shapes("ConsumerProfile")
PPShape.TextFrame.TextRange.Text = ThisWorkbook.Sheets("Category Review").Range("AP116").Value
Set PPSlide = PPPrsn.Slides(21)
AppActivate "Category Review Links"
Set PPShape = PPSlide.Shapes("CompetitorByChannel")
PPShape.TextFrame.TextRange.Text = ThisWorkbook.Sheets("Category Review").Range("AP119").Value
Set PPSlide = PPPrsn.Slides(2)
AppActivate "Category Review Links"
Set PPShape = PPSlide.Shapes("Category Manager")
PPShape.TextFrame.TextRange.Text = "CATEGORY MANAGER: " & ThisWorkbook.Sheets("Category Review").Range("AP131").Value
Set PPSlide = PPPrsn.Slides(2)
AppActivate "Category Review Links"
Set PPShape = PPSlide.Shapes("Category Role")
PPShape.TextFrame.TextRange.Text = "CATEGORY ROLE: " & ThisWorkbook.Sheets("Category Review").Range("AP134").Value
Set PPSlide = PPPrsn.Slides(2)
AppActivate "Category Review Links"
Set PPShape = PPSlide.Shapes("Category Class")
PPShape.TextFrame.TextRange.Text = "CATEGORY CLASS: " & ThisWorkbook.Sheets("Category Review").Range("AP137").Value
Set PPSlide = PPPrsn.Slides(2)
AppActivate "Category Review Links"
Set PPShape = PPSlide.Shapes("Category Strategy")
PPShape.TextFrame.TextRange.Text = "CATEGORY STRATEGY: " & ThisWorkbook.Sheets("Category Review").Range("AP140").Value
Set PPSlide = PPPrsn.Slides(2)
AppActivate "Category Review Links"
Set PPShape = PPSlide.Shapes("Definition")
PPShape.TextFrame.TextRange.Text = "DEFINITION: " & ThisWorkbook.Sheets("Category Review").Range("AP156").Value
Set PPSlide = PPPrsn.Slides(2)
AppActivate "Category Review Links"
Set PPShape = PPSlide.Shapes("Definition")
PPShape.TextFrame.TextRange.Text = "DEFINITION: " & ThisWorkbook.Sheets("Category Review").Range("AP156").Value
WriteTextFile
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 Links"
NewPPTFileName = Left(NewPPTFileName, Len(NewPPTFileName) - 5)
ThatWasEasy
AppActivate NewPPTFileName
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 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 ReCalculate()
Calculate
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 AdjustPPTSettings()
Sheets("Adjust PPT Settings").Select
End Sub
Sub ReturnToInstructions()
Sheets("Instructions").Select
End Sub
Function GetDownloadPath() As String
GetDownloadPath = Environ("USERPROFILE") & "\Downloads"
End Function
Function GetDesktPPath()
Dim WSHShell As Object
Set WSHShell = CreateObject("Wscript.Shell")
GetDesktPPath = WSHShell.SpecialFolders(4)
If Right(GetDesktPPath, 1) <> "\" Then
GetDesktPPath = GetDesktPPath & "\"
End If
End Function
Public Sub CheckAppPosition()
If Application.Left <> theAppPos Then
theAppPos = Application.Left
End If
If theAppPos < 200 Then
If theAppScreen <> "Left" Then
theAppScreen = "Left"
MsgBox "The app is left"
Else
End If
ElseIf theAppPos > 200 And theAppPos < 1200 Then
If theAppScreen <> "Right" Then
theAppScreen = "Right"
MsgBox "the app is right"
Else
End If
Else
End If
alertTime = Now + TimeValue("00:00:05")
Application.OnTime alertTime, "CheckAppPosition"
End Sub