Option Explicit
Option Compare Text
#If VBA7 And Win64 Then
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongLong, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr
#ElseIf VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hWnd As LongPtr, ByVal nIDEvent As Long) As Long
#Else
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
#End If
#If VBA7 Then
#If Win64 Then
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 SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
#Else
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong 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 Long
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As Long
#End If
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long
#Else
private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1$, ByVal lpsz2$) As Long
private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
#End If
Const n_ = vbNullString
Private Type v64
#If VBA7 And Win64 Then
z As LongLong
#ElseIf VBA7 Then
z As LongPtr
#Else
z As Long
#End If
End Type
Private FullScreenEnabled As Boolean
Private Sub modeForDeveloper_test()
Call modeForDeveloper
End Sub
Private Function RibbonVisible() As Boolean
RibbonVisible = Application.CommandBars("Ribbon").Visible
End Function
Sub modeForDeveloper(Optional direction%)
FullScreenEnabled = False
Dim i%
Select Case True
Case direction > 0: i = 1
Case direction = 0: i = IIf(RibbonVisible, -1, 1)
Case direction < 0: i = -1
End Select
setupWindowInterface , FormulaBar:=i, Headings:=i, StatusBar:=i, WorkbookTabs:=i, _
ScrollBar:=i, ToolBar:=i, MenuBar:=i, AllSheets:=0, AllWindows:=1, LoadFormBorders:=1
FullScreenEnabled = i = -1
End Sub
Function toggleFullScreen()
On Error Resume Next
toggleFullScreen = "[FullScreen]"
Dim r As Range
Set r = Application.ThisCell
If Not r Is Nothing Then
Call SetTimer(Application.hWnd, 100, 0, AddressOf TimerProc_FullScreen)
Exit Function
End If
Dim w: Set w = Application.ActiveWindow
Dim b As Boolean, s$, i%, l As Boolean
b = RibbonVisible Or w.DisplayHeadings _
Or w.DisplayWorkbookTabs _
Or Application.DisplayFormulaBar _
Or Application.DisplayStatusBar _
Or w.DisplayHeadings
i = IIf(b, -1, 1)
setupWindowInterface w, i, i, i, i, i, i, i, AllSheets:=0, AllWindows:=0, LoadFormBorders:=True
FullScreenEnabled = b
If b Then
s = "C" & ChrW(7916) & "A S" & ChrW(7892) & " " & ChrW(272) & ChrW(195) & " M" & ChrW(7902) & " R" & ChrW(7896) & "NG"
Else
s = "CH" & ChrW(7870) & " " & ChrW(272) & ChrW(7896) & " CH" & ChrW(7880) & "NH S" & ChrW(7916) & "A"
End If
e:
End Function
#If VBA7 And Win64 Then
Private Sub TimerProc_FullScreen(ByVal hWnd As LongPtr, ByVal wMsg^, ByVal IdEvent As LongPtr, ByVal dwTime^)
#ElseIf VBA7 Then
Private Sub TimerProc_FullScreen(ByVal hWnd As LongPtr, ByVal wMsg&, ByVal IdEvent As LongPtr, ByVal dwTime&)
#Else
Private Sub TimerProc_FullScreen(ByVal hWnd&, ByVal wMsg&, ByVal IdEvent&, ByVal dwTime&)
#End If
On Error Resume Next
KillTimer hWnd, IdEvent
SendKeys "^z", False
toggleFullScreen
On Error GoTo 0
End Sub
Private Sub setupWindowInterface(Optional ByVal win As window, _
Optional FormulaBar% = 0, _
Optional Headings% = 0, _
Optional StatusBar% = 0, _
Optional WorkbookTabs% = 0, _
Optional ScrollBar% = 0, _
Optional ToolBar% = 0, _
Optional MenuBar% = 0, _
Optional AllSheets As Boolean = False, _
Optional AllWindows As Boolean = False, _
Optional LoadFormBorders As Boolean = False)
' On Error Resume Next
If win Is Nothing Then Set win = ActiveWindow
Dim h As v64, s$, w As Object, w1, w2, b As Boolean, c As Boolean
Dim o As Object, n As Object, Book As Object, e As Boolean, e2%
c = ExcelNewVersion: s = win.Caption
Set Book = win.Parent
With Application
Set n = .ActiveWindow
GoSub Activate
If FormulaBar <> 0 Then If .DisplayFormulaBar <> (FormulaBar = 1) Then .DisplayFormulaBar = (FormulaBar = 1)
If StatusBar <> 0 Then If .DisplayStatusBar <> (StatusBar = 1) Then .DisplayStatusBar = (StatusBar = 1)
If Headings <> 0 Then
If AllSheets Then
Set w1 = .ActiveSheet
For Each w2 In Book.Worksheets
If w2.Visible Then w2.Activate: If win.DisplayHeadings <> (Headings = 1) Then win.DisplayHeadings = (Headings = 1)
Next
w1.Activate
Else
If win.DisplayHeadings <> (Headings = 1) Then win.DisplayHeadings = (Headings = 1)
End If
End If
If AllWindows Then
For Each w In Application.Windows:
DoEvents
If w.Visible Then Call SpeedOn(-1, e2): w.Activate: Call SpeedOff(-1, e2): GoSub chung:
Next
Else
Set w = win: GoSub chung
End If
If Not c And MenuBar <> 0 Then h.z = .hWnd: setWindowMenuBar h, (MenuBar = 1)
If n.Caption <> win.Caption Then Call SpeedOn(-1, e2): n.Activate: Call SpeedOff(-1, e2)
Exit Sub
chung:
'.CommandBars.ExecuteMso "HideRibbon"
'.DisplayFullScreen = ToolBar
With w
If ScrollBar <> 0 Then
If .DisplayVerticalScrollBar <> (ScrollBar = 1) Then .DisplayVerticalScrollBar = ScrollBar = 1
If .DisplayHorizontalScrollBar <> (ScrollBar = 1) Then .DisplayHorizontalScrollBar = ScrollBar = 1
If Application.DisplayScrollBars <> (ScrollBar = 1) Then Application.DisplayScrollBars = ScrollBar = 1
End If
If Headings <> 0 Then If .DisplayHeadings <> (Headings = 1) Then .DisplayHeadings = Headings = 1
If WorkbookTabs <> 0 Then If .DisplayWorkbookTabs <> (WorkbookTabs = 1) Then .DisplayWorkbookTabs = WorkbookTabs = 1
End With
If MenuBar <> 0 Then
If w.WindowState = xlMaximized Then w.WindowState = xlNormal
setWindowMenuBar WindowWorksheet(w), (MenuBar = 1)
End If
If ToolBar <> 0 Then
If .CommandBars("Ribbon").Visible <> (ToolBar = 1) Then
.ExecuteExcel4Macro "Show.ToolBar(""Ribbon"", " & CStr(ToolBar = 1) & ")"
End If
End If
Return
End With
Activate:
If Not b Then b = True: If n.Caption <> win.Caption Then Call SpeedOn(-1, e2): win.Activate: Call SpeedOff(-1, e2)
Return
End Sub
Private Function WindowActivate(Optional ByVal window As Object) As Boolean
If window Is Nothing Then Set window = ActiveWindow
On Error Resume Next: AppActivate window.Caption: WindowActivate = Err = 0
End Function
Private Sub SpeedOn( _
Optional Screen% = 1, Optional Events% = 1, Optional Calcula% = -1, Optional Display% = -1, Optional CalSave% = -1)
AppFaster True, Screen, Events, Calcula, Display, CalSave
End Sub
Private Sub SpeedOff(Optional Screen% = 1, Optional Events% = 1, Optional Calcula% = -1, Optional Display% = -1, Optional CalSave% = -1)
AppFaster False, Screen, Events, Calcula, Display, CalSave
End Sub
Private Sub AppFaster(Optional ByVal fast As Boolean = False, _
Optional Screen% = 1, Optional Events% = 1, Optional Calcula% = -1, Optional Display% = -1, Optional CalSave% = -1)
'Fast: 0 | 1
'Slow: 0 | 1 | 2 | 3
'Skip: #0 #1
Static s%, e%, c%, D%, i%
Dim V1%, v2%, v3&, k%, b%
V1 = Screen: v2 = s: GoSub SW: Screen = V1: s = v2
V1 = Events: v2 = e: GoSub SW: Events = V1: e = v2
V1 = Calcula: v2 = c: GoSub SW: Calcula = V1: c = v2
V1 = Display: v2 = D: GoSub SW: Display = V1: D = v2
V1 = CalSave: v2 = i: GoSub SW: CalSave = V1: i = v2
Exit Sub
SW: k = k + 1: v3 = 0: b = 0
If fast Then GoSub fast Else GoSub slow
Return
fast:
With Application
Select Case True
Case V1 = 0 And v2 = 0: b = 1
Case V1 = 0 And v2 = 2: b = 2
Case V1 = 1 And v2 = 0: b = 3
End Select
If b Then
Select Case k
Case 1: v3 = .ScreenUpdating: If v3 Then .ScreenUpdating = False
Case 2: v3 = .EnableEvents: If v3 Then .EnableEvents = False
Case 3: v3 = .Calculation <> -4135: If v3 Then .Calculation = -4135
Case 4: v3 = .DisplayAlerts: If v3 Then .DisplayAlerts = False
Case 5: v3 = .CalculateBeforeSave: If v3 Then .CalculateBeforeSave = False
Case 6: v3 = .Cursor <> xlWait: If v3 Then .Cursor = xlWait
Case 7: v3 = .StatusBar: If v3 Then .StatusBar = False
Case 8: v3 = .EnableCancelKey <> xlErrorHandler: If v3 Then .EnableCancelKey = xlErrorHandler
End Select
If v3 Then
Select Case b
Case 1: V1 = IIf(V1 = 0, 2, 1): v2 = 1
Case 2: V1 = IIf(V1 = 0, 1, 1): v2 = 1
Case 3: V1 = IIf(V1 = 0, 2, 1): v2 = 1
End Select
End If
End If
End With
Return
slow:
With Application
Select Case True
Case V1 = 0 And v2 = 0: b = 1
Case V1 = 1 And v2 = 0: b = 2
Case V1 = 2 And v2 = 1: b = 3: v2 = 0
Case V1 = 3: b = 4: v2 = Switch(v2 = 0, 0, v2 = 1, 2, True, 2)
End Select
If b Then
Select Case k
Case 1: v3 = .ScreenUpdating: If v3 = 0 Then .ScreenUpdating = True
Case 2: v3 = .EnableEvents: If v3 = 0 Then .EnableEvents = True
Case 3: v3 = .Calculation = -4105: If v3 = 0 Then .Calculation = -4105
Case 4: v3 = .DisplayAlerts: If v3 = 0 Then .DisplayAlerts = True
Case 5: v3 = .CalculateBeforeSave: If v3 = 0 Then .CalculateBeforeSave = True
Case 6: v3 = .Cursor <> xlDefault: If v3 Then .Cursor = xlDefault
Case 7: v3 = .StatusBar: If v3 Then .StatusBar = False
Case 8: v3 = .EnableCancelKey <> xlInterrupt: If v3 Then .EnableCancelKey = xlInterrupt
End Select
End If
End With
Return
End Sub
Private Function WindowWorksheet(ByVal win As Object, Optional xl7 As Boolean) As v64
Dim h As v64:
If Val(Application.Version) > 14 Then
h.z = win.hWnd: If xl7 Then h.z = FindWindowEx(FindWindowEx(h.z, 0&, "XLDESK", n_), 0&, "EXCEL7", n_)
Else
Dim z As v64:
z.z = FindWindowEx(Application.hWnd, 0&, "XLDESK", n_)
h.z = FindWindowEx(z.z, 0&, "EXCEL7", win.Caption)
If h.z = 0 Then
h.z = FindWindowEx(z.z, 0&, "EXCEL7", win.Caption & " [Read-Only]"):
If h.z = 0 Then
h.z = FindWindowEx(z.z, 0&, "EXCEL7", win.Caption & " [Repair]"):
If h.z = 0 Then h.z = FindWindowEx(z.z, 0&, "EXCEL7", win.Caption & " [Repaired]")
End If
End If
End If
WindowWorksheet = h
End Function
Private Sub setWindowMenuBar(hWnd As v64, Optional ByVal show As Boolean = True)
With hWnd
If show Then
SetWindowLong .z, -16, GetWindowLong(.z, -16) Or &HC00000
SetWindowLong .z, -20, GetWindowLong(.z, -20) Or &H1
Else
SetWindowLong .z, -16, GetWindowLong(.z, -16) And Not &HC00000
SetWindowLong .z, -20, GetWindowLong(.z, -20) And Not &H1
End If
DrawMenuBar .z
End With
End Sub
Private Function ExcelNewVersion() As Boolean
ExcelNewVersion = Val(Application.Version) > 14
End Function
