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

gmooney

Active Member
Joined
Oct 21, 2004
Messages
252
Office Version
  1. 365
Platform
  1. Windows
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?
 
You have Option Explicit turned on. You'll need to declare the variable using "Dim alterTime As Variant" then if you have that set.
 
Upvote 0

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
Hi richh,

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

Here is my entire code:

VBA 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
 
Upvote 0
Sorry richh,

I got the same error on the above code
 
Upvote 0
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.
 
Upvote 0
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.....
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,213,520
Messages
6,114,099
Members
448,548
Latest member
harryls

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