Check if printing entire sheet or just selection

D

Dave_T_

New Member
Joined
May 23, 2019
Messages
11
Good afternoon,

I have a spreadsheet that is a continuous log of data with dates and times. I am dynamically changing the footer based on the user's selection and including the selected date range for the report as part of the footer. This is all working fine.

What I would like to do is check to see if the user has selected "print selection" or "print active sheet" from the print dialog screen. That way I can disable the date range in the footer if the whole sheet is being printed. Currently, if the user is printing the whole sheet, the report footer only displays the date range from the current selection.

I am using VBA in Excel 2016.
 
Sort by date Sort by votes
Jaafar Tribak said:
The following code worked for me in excel 2016.

Basically, the code starts a timer upon opening the workbook and continuously monitors the UI Print setup window to detect the type of printing being requested by the user.

In this example (see second code) , if the user chooses to Print Selection, the printing is cancelled and the user is notified.

.
.
.

Unfortunately, the code uses a timer which is best avoided but I couldn't find another way.

In addition, the code relies on the specific UI layout of the Print setup window in excel 2016 so I am not sure it will work in other excel versions and it is also language dependent.
Click to expand...


Jaafar,

This does exactly what I need it to do. I'm going to spend some time digging into this a bit to get a better understanding of exactly how it works, but for now, the problem is taken care of.

Thank you!
 
Upvote 0

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Dave_T_ said:
Jaafar,

This does exactly what I need it to do. I'm going to spend some time digging into this a bit to get a better understanding of exactly how it works, but for now, the problem is taken care of.

Thank you!
Click to expand...

You are welcome.

As I mentioned earlier, although the code works well when I tested it, do not forget the fact that it uses a windows timer callback so I am not sure how stable it will be in the long run.

EDIt:
If I find the time, I'll see if I can make the code run from a seperate hidden excel instance .. This is to avoid all potential problems when using a windows timer.
 
Last edited:
Upvote 0
Jaafar Tribak said:
You are welcome.

As I mentioned earlier, although the code works well when I tested it, do not forget the fact that it uses a windows timer callback so I am not sure how stable it will be in the long run.

EDIt:
If I find the time, I'll see if I can make the code run from a seperate hidden excel instance .. This is to avoid all potential problems when using a windows timer.
Click to expand...

One weird quirk is that when the timer or application monitoring is running in any workbook, intellisense does not work in that application instance. Other that that, I haven't found any major issues yet.
 
Upvote 0
Dave_T_ said:
One weird quirk is that when the timer or application monitoring is running in any workbook, intellisense does not work in that application instance. Other that that, I haven't found any major issues yet.
Click to expand...

I seem to have managed to make the timer code run from a seperate hidden instance of excel .. This should avoid all the above mentioned issues related to running a windows timer within the vba project.

Workbook example


1- Code in a Standard Module:
Code: 
Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "Oleacc" (ByVal hWnd As LongPtr, ByVal dwId As Long, ByRef riid As GUID, ByRef ppvObject As Any) As Long
    Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal arg1 As LongPtr, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare PtrSafe Function AccessibleChildren Lib "Oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, lpiid As GUID) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hWnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
    Private Declare PtrSafe Function GlobalGetAtomName Lib "kernel32" Alias "GlobalGetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Private Declare PtrSafe Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function CoDisconnectObject Lib "ole32.dll" (ByVal pUnk As IUnknown, pvReserved As Long) As Long
    Private Declare PtrSafe Function RegisterActiveObject Lib "oleaut32.dll" (ByVal pUnk As IUnknown, rclsid As Any, ByVal dwFlags As Long, pdwRegister As Long) As Long
    Private Declare PtrSafe Function GetActiveObject Lib "OleAut32" (rclsid As Any, ByVal pvReserved As LongPtr, ppunk As Any) As Long
    Private Declare PtrSafe Function RevokeActiveObject Lib "oleaut32.dll" (ByVal dwRegister As Long, ByVal pvReserved As Long) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "Ole32" (ByVal lpsz As LongPtr, pclsid As Any) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function AccessibleObjectFromWindow Lib "Oleacc" (ByVal hwnd As Long, ByVal dwId As Long, ByRef riid As GUID, ByRef ppvObject As Any) As Long
    Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Function AccessibleChildren Lib "Oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, lpiid As GUID) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
    Private Declare Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
    Private Declare Function GlobalGetAtomName Lib "kernel32" Alias "GlobalGetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Private Declare Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
    Private Declare Function CoDisconnectObject Lib "ole32.dll" (ByVal pUnk As IUnknown, pvReserved As Long) As Long
    Private Declare Function RegisterActiveObject Lib "oleaut32.dll" (ByVal pUnk As IUnknown, rclsid As Any, ByVal dwFlags As Long, pdwRegister As Long) As Long
    Private Declare Function GetActiveObject Lib "OleAut32" (rclsid As Any, ByVal pvReserved As Long, ppunk As Any) As Long
    Private Declare Function RevokeActiveObject Lib "oleaut32.dll" (ByVal dwRegister As Long, ByVal pvReserved As Long) As Long
    Private Declare Function CLSIDFromString Lib "Ole32" (ByVal lpsz As Long, pclsid As Any) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If



Public Function PrintWhat() As String

    Dim Atom_ID As Integer, lRet As Long, sBuffer  As String * 256
    
    Atom_ID = CInt(GetProp(GetDesktopWindow, "PrintArea_String"))
    lRet = GlobalGetAtomName(Atom_ID, sBuffer, Len(sBuffer))
    PrintWhat = Left(sBuffer, lRet)

End Function

Public Sub CreateHiddenInstance()

    Dim Atom_ID As Integer, lRet As Long, Wb As Workbook, oXl As Excel.Application
    
    If Not ThisWorkbook.ReadOnly Then
        Call DeleteHiddenInstance
        If GetProp(GetDesktopWindow, "SourceXlHwnd_String") = 0 Then
            Set oXl = New Application
            'oXl.Visible = True '<== For Testing
            oXl.EnableEvents = False
            Set Wb = oXl.Workbooks.Open(ThisWorkbook.FullName, False, True)
            Atom_ID = GlobalAddAtom(Application.hWnd)
            SetProp GetDesktopWindow, "SourceXlHwnd_String", Atom_ID
            Call oXl.Run("StartTimerFromHiddenInstance")
        End If
    End If

End Sub

Public Sub DeleteHiddenInstance()

    Dim pUnk As IUnknown, Wb As Workbook, ClassID(0 To 3) As Long
    Dim Atom_ID As Integer, lRet As Long, sBuffer  As String * 256
    
    If Not ThisWorkbook.ReadOnly And GetProp(GetDesktopWindow, "SourceXlHwnd_String") Then
        Call CoDisconnectObject(ThisWorkbook, 0)
        Call RevokeActiveObject(CLng(GetProp(GetDesktopWindow, "OleId")), 0)
        Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35267}"), ClassID(0))
        Call GetActiveObject(ClassID(0), 0, pUnk)
        Set Wb = pUnk
        Set pUnk = Nothing
        If Not Wb Is Nothing Then
            On Error Resume Next
            Call Wb.Parent.Run("StopTimerFromHiddenInstance")
            Wb.Saved = True: Wb.Parent.Quit: Set Wb = Nothing
        End If
        Atom_ID = CInt(GetProp(GetDesktopWindow, "SourceXlHwnd_String"))
        Call GlobalDeleteAtom(Atom_ID)
        Atom_ID = CInt(GetProp(GetDesktopWindow, "PrintArea_String"))
        Call GlobalDeleteAtom(Atom_ID)
        Call RemoveProp(GetDesktopWindow, "OleId")
        Call RemoveProp(GetDesktopWindow, "SourceXlHwnd_String")
        Call RemoveProp(GetDesktopWindow, "PrintArea_String")
    End If

End Sub



[B][COLOR=#008000]'Hidden Instance routines:[/COLOR][/B]
[B][COLOR=#008000]'========================[/COLOR][/B]
Private Sub StartTimerFromHiddenInstance()

    Dim ClassID(0 To 3) As Long, lOleId As Long
    
    If GetProp(GetDesktopWindow, "OleId") = 0 Then
        Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35267}"), ClassID(0))
        Call RegisterActiveObject(ThisWorkbook, ClassID(0), 0, lOleId)
        Call SetProp(GetDesktopWindow, "OleId", lOleId)
        Call SetTimer(Application.hWnd, 0, 100, AddressOf TimerProc)
    End If

End Sub

Private Sub StopTimerFromHiddenInstance()

    Call KillTimer(Application.hWnd, 0)
    Call RemoveProp(GetDesktopWindow, "OleId")
    Call RemoveProp(GetDesktopWindow, "SourceXlHwnd_String")
    Call RemoveProp(GetDesktopWindow, "PrintArea_String")
    'Debug.Print "Timer stopped" '<== For Testing
    
End Sub

Private Sub TimerProc()

    Const CHILDID_SELF = &H0&
    Const OBJID_CLIENT = &HFFFFFFFC
    Const IID_IAccessible = "{618736E0-3C3D-11CF-810C-00AA00389B71}"

    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim hWnd As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim hWnd As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    
    Dim oAccNetUIHWND As IAccessible, oIAccPrintWhat As IAccessible, vCopiesField As Variant
    Dim lLeft As Long, lTop As Long, lWidth As Long, lHeight As Long
    Dim Atom_ID As Integer, lRet As Long, sBuffer  As String * 256
    Dim IID As GUID

    On Error Resume Next
    
    If ThisWorkbook.ReadOnly And GetProp(GetDesktopWindow, "SourceXlHwnd_String") Then
        Atom_ID = CInt(GetProp(GetDesktopWindow, "SourceXlHwnd_String"))
        lRet = GlobalGetAtomName(Atom_ID, sBuffer, Len(sBuffer))
        
        hWnd = FindWindowEx(Left(sBuffer, lRet), 0, "FullpageUIHost", vbNullString)
        hWnd = GetNextWindow(hWnd, 5): hWnd = GetNextWindow(hWnd, 5)
        Call IIDFromString(StrPtr(IID_IAccessible), IID)
        Call AccessibleObjectFromWindow(hWnd, OBJID_CLIENT, IID, oAccNetUIHWND)
        Call AccessibleChildren(oAccNetUIHWND, 0, 1, vCopiesField, 1)
        Call vCopiesField.accLocation(lLeft, lTop, lWidth, lHeight, CHILDID_SELF)
        
        [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
            Dim lngPtr As LongPtr
            Dim arPt(0 To 1) As Long
            arPt(0) = lLeft: arPt(1) = lTop + (lHeight * 15)
            lngPtr = arPt(1) * &H100000000^ Or arPt(0)
            Call AccessibleObjectFromPoint(lngPtr, oIAccPrintWhat, 0)
        [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
            Call AccessibleObjectFromPoint(lLeft, lTop + (lHeight * 15), oIAccPrintWhat, 0)
        [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
        
        Atom_ID = GlobalAddAtom(oIAccPrintWhat.accValue(CHILDID_SELF))
        SetProp GetDesktopWindow, "PrintArea_String", Atom_ID
    End If

End Sub



2- Code in the ThisWorkbook Module:
(In this example, if the user chooses 'Print Selection', the printing is cancelled and the user is notyfied)
Code: 
Option Explicit

Private Sub Workbook_Activate()
    Call CreateHiddenInstance
End Sub

Private Sub Workbook_Deactivate()
    Call DeleteHiddenInstance
End Sub

Private Sub Workbook_BeforePrint(Cancel As Boolean)

    Dim sPrintWhat As String

    sPrintWhat = PrintWhat
    
    Debug.Print sPrintWhat
    
[B][COLOR=#008000]    'run your code here depending on the PrintWhat[/COLOR][/B]
    
    If sPrintWhat = "Print Selection" Then
        MsgBox sPrintWhat & vbCrLf & vbCrLf & "Printing Cancelled."
        Cancel = True [COLOR=#008000][B]'<== Cancel printing if Print Selection.[/B][/COLOR]
    End If
End Sub


Copy the code and save the workbook to disk... Next time you open the workbook, a clone of the code is created on the fly in a seperate hidden instance.. The windows timer is executed from there. Once the main workbook is closed, the hidden instance automatically closes down.

If it is worthwhile, I'll try to test this in versions of excel other than 2016 and if all goes well, maybe I'll exapand the code to detect other Print settings such as number of copies,Printer, Scalling etc.

Regards.
 
Last edited:
Upvote 0
Thanks. I'll give this a go in the next few days. For now, we have the other solution in place and it is working, so there isn't a rush. I appreciate the time you have spent on this. I can see how expanding this to other versions of Excel could also be helpful, as well as the ability to read other properties. I'm always interested in gathering these types of resources.
 
Upvote 0
Jaafar Tribak said:
I seem to have managed to make the timer code run from a seperate hidden instance of excel .. This should avoid all the above mentioned issues related to running a windows timer within the vba project.

Workbook example


1- Code in a Standard Module:
Code: 
Option Explicit

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "Oleacc" (ByVal hWnd As LongPtr, ByVal dwId As Long, ByRef riid As GUID, ByRef ppvObject As Any) As Long
    Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal arg1 As LongPtr, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare PtrSafe Function AccessibleChildren Lib "Oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, lpiid As GUID) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hWnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
    Private Declare PtrSafe Function GlobalGetAtomName Lib "kernel32" Alias "GlobalGetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Private Declare PtrSafe Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function CoDisconnectObject Lib "ole32.dll" (ByVal pUnk As IUnknown, pvReserved As Long) As Long
    Private Declare PtrSafe Function RegisterActiveObject Lib "oleaut32.dll" (ByVal pUnk As IUnknown, rclsid As Any, ByVal dwFlags As Long, pdwRegister As Long) As Long
    Private Declare PtrSafe Function GetActiveObject Lib "OleAut32" (rclsid As Any, ByVal pvReserved As LongPtr, ppunk As Any) As Long
    Private Declare PtrSafe Function RevokeActiveObject Lib "oleaut32.dll" (ByVal dwRegister As Long, ByVal pvReserved As Long) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "Ole32" (ByVal lpsz As LongPtr, pclsid As Any) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
    Private Declare Function AccessibleObjectFromWindow Lib "Oleacc" (ByVal hwnd As Long, ByVal dwId As Long, ByRef riid As GUID, ByRef ppvObject As Any) As Long
    Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Function AccessibleChildren Lib "Oleacc" (ByVal paccContainer As Office.IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As Long, lpiid As GUID) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
    Private Declare Function GetDesktopWindow Lib "user32" () As Long
    Private Declare Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
    Private Declare Function GlobalGetAtomName Lib "kernel32" Alias "GlobalGetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Private Declare Function GlobalDeleteAtom Lib "kernel32" (ByVal nAtom As Integer) As Integer
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
    Private Declare Function CoDisconnectObject Lib "ole32.dll" (ByVal pUnk As IUnknown, pvReserved As Long) As Long
    Private Declare Function RegisterActiveObject Lib "oleaut32.dll" (ByVal pUnk As IUnknown, rclsid As Any, ByVal dwFlags As Long, pdwRegister As Long) As Long
    Private Declare Function GetActiveObject Lib "OleAut32" (rclsid As Any, ByVal pvReserved As Long, ppunk As Any) As Long
    Private Declare Function RevokeActiveObject Lib "oleaut32.dll" (ByVal dwRegister As Long, ByVal pvReserved As Long) As Long
    Private Declare Function CLSIDFromString Lib "Ole32" (ByVal lpsz As Long, pclsid As Any) As Long
[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If



Public Function PrintWhat() As String

    Dim Atom_ID As Integer, lRet As Long, sBuffer  As String * 256
    
    Atom_ID = CInt(GetProp(GetDesktopWindow, "PrintArea_String"))
    lRet = GlobalGetAtomName(Atom_ID, sBuffer, Len(sBuffer))
    PrintWhat = Left(sBuffer, lRet)

End Function

Public Sub CreateHiddenInstance()

    Dim Atom_ID As Integer, lRet As Long, Wb As Workbook, oXl As Excel.Application
    
    If Not ThisWorkbook.ReadOnly Then
        Call DeleteHiddenInstance
        If GetProp(GetDesktopWindow, "SourceXlHwnd_String") = 0 Then
            Set oXl = New Application
            'oXl.Visible = True '<== For Testing
            oXl.EnableEvents = False
            Set Wb = oXl.Workbooks.Open(ThisWorkbook.FullName, False, True)
            Atom_ID = GlobalAddAtom(Application.hWnd)
            SetProp GetDesktopWindow, "SourceXlHwnd_String", Atom_ID
            Call oXl.Run("StartTimerFromHiddenInstance")
        End If
    End If

End Sub

Public Sub DeleteHiddenInstance()

    Dim pUnk As IUnknown, Wb As Workbook, ClassID(0 To 3) As Long
    Dim Atom_ID As Integer, lRet As Long, sBuffer  As String * 256
    
    If Not ThisWorkbook.ReadOnly And GetProp(GetDesktopWindow, "SourceXlHwnd_String") Then
        Call CoDisconnectObject(ThisWorkbook, 0)
        Call RevokeActiveObject(CLng(GetProp(GetDesktopWindow, "OleId")), 0)
        Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35267}"), ClassID(0))
        Call GetActiveObject(ClassID(0), 0, pUnk)
        Set Wb = pUnk
        Set pUnk = Nothing
        If Not Wb Is Nothing Then
            On Error Resume Next
            Call Wb.Parent.Run("StopTimerFromHiddenInstance")
            Wb.Saved = True: Wb.Parent.Quit: Set Wb = Nothing
        End If
        Atom_ID = CInt(GetProp(GetDesktopWindow, "SourceXlHwnd_String"))
        Call GlobalDeleteAtom(Atom_ID)
        Atom_ID = CInt(GetProp(GetDesktopWindow, "PrintArea_String"))
        Call GlobalDeleteAtom(Atom_ID)
        Call RemoveProp(GetDesktopWindow, "OleId")
        Call RemoveProp(GetDesktopWindow, "SourceXlHwnd_String")
        Call RemoveProp(GetDesktopWindow, "PrintArea_String")
    End If

End Sub



[B][COLOR=#008000]'Hidden Instance routines:[/COLOR][/B]
[B][COLOR=#008000]'========================[/COLOR][/B]
Private Sub StartTimerFromHiddenInstance()

    Dim ClassID(0 To 3) As Long, lOleId As Long
    
    If GetProp(GetDesktopWindow, "OleId") = 0 Then
        Call CLSIDFromString(StrPtr("{88D97E8B-D351-4FF4-A8EB-BF18EDD35267}"), ClassID(0))
        Call RegisterActiveObject(ThisWorkbook, ClassID(0), 0, lOleId)
        Call SetProp(GetDesktopWindow, "OleId", lOleId)
        Call SetTimer(Application.hWnd, 0, 100, AddressOf TimerProc)
    End If

End Sub

Private Sub StopTimerFromHiddenInstance()

    Call KillTimer(Application.hWnd, 0)
    Call RemoveProp(GetDesktopWindow, "OleId")
    Call RemoveProp(GetDesktopWindow, "SourceXlHwnd_String")
    Call RemoveProp(GetDesktopWindow, "PrintArea_String")
    'Debug.Print "Timer stopped" '<== For Testing
    
End Sub

Private Sub TimerProc()

    Const CHILDID_SELF = &H0&
    Const OBJID_CLIENT = &HFFFFFFFC
    Const IID_IAccessible = "{618736E0-3C3D-11CF-810C-00AA00389B71}"

    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim hWnd As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim hWnd As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
    
    Dim oAccNetUIHWND As IAccessible, oIAccPrintWhat As IAccessible, vCopiesField As Variant
    Dim lLeft As Long, lTop As Long, lWidth As Long, lHeight As Long
    Dim Atom_ID As Integer, lRet As Long, sBuffer  As String * 256
    Dim IID As GUID

    On Error Resume Next
    
    If ThisWorkbook.ReadOnly And GetProp(GetDesktopWindow, "SourceXlHwnd_String") Then
        Atom_ID = CInt(GetProp(GetDesktopWindow, "SourceXlHwnd_String"))
        lRet = GlobalGetAtomName(Atom_ID, sBuffer, Len(sBuffer))
        
        hWnd = FindWindowEx(Left(sBuffer, lRet), 0, "FullpageUIHost", vbNullString)
        hWnd = GetNextWindow(hWnd, 5): hWnd = GetNextWindow(hWnd, 5)
        Call IIDFromString(StrPtr(IID_IAccessible), IID)
        Call AccessibleObjectFromWindow(hWnd, OBJID_CLIENT, IID, oAccNetUIHWND)
        Call AccessibleChildren(oAccNetUIHWND, 0, 1, vCopiesField, 1)
        Call vCopiesField.accLocation(lLeft, lTop, lWidth, lHeight, CHILDID_SELF)
        
        [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
            Dim lngPtr As LongPtr
            Dim arPt(0 To 1) As Long
            arPt(0) = lLeft: arPt(1) = lTop + (lHeight * 15)
            lngPtr = arPt(1) * &H100000000^ Or arPt(0)
            Call AccessibleObjectFromPoint(lngPtr, oIAccPrintWhat, 0)
        [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
            Call AccessibleObjectFromPoint(lLeft, lTop + (lHeight * 15), oIAccPrintWhat, 0)
        [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
        
        Atom_ID = GlobalAddAtom(oIAccPrintWhat.accValue(CHILDID_SELF))
        SetProp GetDesktopWindow, "PrintArea_String", Atom_ID
    End If

End Sub



2- Code in the ThisWorkbook Module:
(In this example, if the user chooses 'Print Selection', the printing is cancelled and the user is notyfied)
Code: 
Option Explicit

Private Sub Workbook_Activate()
    Call CreateHiddenInstance
End Sub

Private Sub Workbook_Deactivate()
    Call DeleteHiddenInstance
End Sub

Private Sub Workbook_BeforePrint(Cancel As Boolean)

    Dim sPrintWhat As String

    sPrintWhat = PrintWhat
    
    Debug.Print sPrintWhat
    
[B][COLOR=#008000]    'run your code here depending on the PrintWhat[/COLOR][/B]
    
    If sPrintWhat = "Print Selection" Then
        MsgBox sPrintWhat & vbCrLf & vbCrLf & "Printing Cancelled."
        Cancel = True [COLOR=#008000][B]'<== Cancel printing if Print Selection.[/B][/COLOR]
    End If
End Sub


Copy the code and save the workbook to disk... Next time you open the workbook, a clone of the code is created on the fly in a seperate hidden instance.. The windows timer is executed from there. Once the main workbook is closed, the hidden instance automatically closes down.

If it is worthwhile, I'll try to test this in versions of excel other than 2016 and if all goes well, maybe I'll exapand the code to detect other Print settings such as number of copies,Printer, Scalling etc.

Regards.
Click to expand...

This works without any issues so far. I have updated our live file with the new code.

Thanks again.
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question Question
Printing to PDF use VBA - Was working but now different sheets are different widths
Replies
1
Views
205
Tanquen
T
imback2nite
  • Question Question
Print size change using VBA.
Replies
4
Views
320
imback2nite
imback2nite
N
  • Question Question
VBA to add title from formula to a save as name
Replies
0
Views
96
NKUNZI
N
I
  • Question Question
Advice for slight alteration to existing working code
Replies
1
Views
219
ipbr21054
I
S
  • Solved
Button to print to PDF with custom file name & custom location
Replies
3
Views
554
mumps
mumps

Forum statistics

Threads
1,223,894
Messages
6,175,250
Members
452,623
Latest member
Techenthusiast

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