Re-run Macro when user moves workbook from one screen to another?

[gmooney]

Hi there,

I have some code that will automatically zoom a worksheet page to automatically fit the screen on any user's screen. However, when they have a laptop and external monitor and they choose to move the workbook from one monitor to the other the zoom doesn't necessarily fit the screen.

Anyway, to have this particular macro fire whenever the workbook moves from one screen to another?

 

[richh]

You have Option Explicit turned on. You'll need to declare the variable using "Dim alterTime As Variant" then if you have that set.

 

[gmooney]

Hi richh,

Sorry I am a novice but learning more every day....

Here is my entire code:

Option Explicit

'Declare globalVars to retain info while app runs
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
        
    'File Path & Name of Text File
    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
    
    'Change this to the relevant file
    PPTemplatestrName = GetDesktPPath & "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 Links"
    '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 Links"
    '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 Links"
    '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 Links"
    '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 Links"
    '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 Links"
    '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 Links"
    '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 Links"
    '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 Links"
    '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
    
    'Change this to the relevant slide which has the shape
    Set PPSlide = PPPrsn.Slides(2)
    AppActivate "Category Review Links"
    '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
    
    '     'open embedded workbook for editing
    '    pptShape.OLEFormat.DoVerb Index:=1
    '
    '    'assign workbook to an object variable
    '    Dim xlWB As Workbook
    '    Set xlWB = pptShape.OLEFormat.Object
    '
    '
    '    'enter text in a cell
    '    xlWB.Worksheets("Sheet1").Range("A1").Value = "This is some sample text . . ."
    
    
    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 'The new position does not match oldPos
        theAppPos = Application.Left
    End If
    
    If theAppPos < 200 Then 'the App is on the left
        If theAppScreen <> "Left" Then 'theApp was moved from the right to the left
            theAppScreen = "Left"
            'Execute the update
            MsgBox "The app is left"
        Else 'The app is still on the same side
        End If
    ElseIf theAppPos > 200 And theAppPos < 1200 Then 'the app is on the right
        If theAppScreen <> "Right" Then 'the App was moved from the left to the right
            theAppScreen = "Right"
            'Execute the update
            MsgBox "the app is right"
        Else 'The app is still on the same side
        End If
    Else 'the application is outside the boundaries of both screens
        '<- Mass panic happens here
    End If
    
    alertTime = Now + TimeValue("00:00:05")
    Application.OnTime alertTime, "CheckAppPosition"
            
End Sub

 

[gmooney]

Sorry richh,

I got the same error on the above code

 

[richh]

Yeah, you got the same error because you didn't declare the variable and have Option Explicit turned on. In the CheckAppPosition, define the variable before it is used.

 

[gmooney]

ricch,

Okay you lost me. I was following but now I I am not sure how to define the variable in CheckAppPosition. Still trying to learn.....

 

[richh]

Huh? You don't know how to define variables in functions and subs..? You have a ton of variables already defined all over your code. It's the "Dim" lines in your code. Since you have Option Explicit on, you need to declare alterTime variable at the top of the CheckAppPosition function. Declare it as a variant.