Option Explicit

'xp default theme
Private Sub Command1_Click()
    mTheme.Cover = frmScreen
    mTheme.ChangeTheme True
End Sub

'classic theme
Private Sub Command2_Click()
    mTheme.Cover = frmScreen
    mTheme.ChangeTheme False
End Sub

Private Sub Form_Terminate()
    Unload Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim f As Form
    Dim ctl As Control
    For Each ctl In Me.Controls
        If TypeOf ctl Is Timer Then
            ctl.Enabled = False
            ctl.Interval = 0
        End If
    Next
    For Each f In Forms
        Unload f
    Next f
End Sub

Option Explicit

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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Private Const BM_CLICK As Long = &HF5
Private iTmrCount As Integer

Private Sub Form_Load()
    Me.WindowState = 0 'normal mode
    Me.Left = 0
    Me.Top = 0
    Me.Width = Screen.Width 'full screen
    Me.Height = Screen.Height
    SetWindowPos hwnd, -1, 0, 0, 0, 0, 3 'set to top
    iTmrCount = 0
    tmrTheme.Interval = 2000 '(2 secs) start timer
End Sub

Private Sub Form_Unload(Cancel As Integer)
    'end timer if open
    tmrTheme.Enabled = False
    tmrTheme.Interval = 0
End Sub

Private Sub tmrTheme_Timer()
    Dim lhWnd As Long
    iTmrCount = iTmrCount + 1 'count for error check
    'find display properties window
    'task manager (and others) use same class so i send the title also
    lhWnd = FindWindowEx(0&, 0&, "#32770", "Display Properties")
    lhWnd = FindWindowEx(lhWnd, 0&, "Button", "OK") 'find ok button
    SendMessage lhWnd, BM_CLICK, 0&, 0& 'click ok to apply theme
    If lhWnd <> 0 Then Remove_Cover 'if ok button found
    If iTmrCount >= 3 Then Remove_Cover '6 second timeout error
End Sub

Private Sub Remove_Cover()
    tmrTheme.Enabled = False
    tmrTheme.Interval = 0 'end timer
    Unload Me 'unload cover (this form)
End Sub

Option Explicit

Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Private mScreenForm As Form
Private mScreenEnabled As Boolean

'theme form for screen cover
Public Property Let Cover(ByVal frm As Form)
    Set mScreenForm = frm
    mScreenEnabled = True
End Property

'change theme
Public Sub ChangeTheme(ByVal inNew As Boolean)
    Dim sDefault As String
    Dim sClassic As String
    Dim lhWnd As Long
On Error GoTo err_handler
    If mScreenEnabled = False Then Exit Sub 'if no cover form exit
    Load mScreenForm 'load cover form
    mScreenForm.Show 'show cover form
    Delay_Timer 1 'short delay (optional)
    sDefault = WindowsDirectory & "\Resources\Themes\Luna.theme" 'xp default theme
    sClassic = WindowsDirectory & "\Resources\Themes\Windows Classic.theme" 'classic theme
    If inNew = True Then 'set xp default theme
        If Len(Dir$(sDefault)) = 0 Then GoTo err_handler 'no theme file error
        'run display properties and set the theme (behind our cover form)
        Shell "rundll32.exe shell32.dll,Control_RunDLL desk.cpl desk,@Themes /Action:OpenTheme /file:" & Chr(34) & sDefault & Chr(34)
    Else 'set classic theme
        If Len(Dir$(sClassic)) = 0 Then GoTo err_handler 'no theme file error
        'run display properties and set the theme (behind our cover form)
        Shell "rundll32.exe shell32.dll,Control_RunDLL desk.cpl desk,@Themes /Action:OpenTheme /file:" & Chr(34) & sClassic & Chr(34)
    End If
    mScreenForm.tmrTheme.Enabled = True 'start timer for apply click
    Delay_Timer 1 'short delay (optional)
    Exit Sub
err_handler:
    Unload mScreenForm
    Exit Sub
End Sub

'get windows path
Private Function WindowsDirectory() As String
    Dim sRet As String, lngRet As Long
    sRet = String$(255, 0)
    lngRet = GetWindowsDirectory(sRet, 255)
    WindowsDirectory = Left$(sRet, lngRet)
End Function

'delay timer
Public Function Delay_Timer(nSeconds)
    Dim nStoptime As Single
    nStoptime = Timer + nSeconds
    Do While Timer <= nStoptime: DoEvents: Loop
End Function