Jump to content

Need help with a Windows Theme changer script.

Outbreaker
 Share

Recommended Posts

Outbreaker

Outbreaker

Posted
Posted (edited)

HI :)

I have a VBScript and i want to change it so i can set the Theme over Command Line like:

Start "" /wait "Apply Theme.vbs" "Theme Name"

And a little check script if the Theme does not exist then a popup box should cam and say Theme not found in ""%SystemRoot%\Resources\Themes" folder.

' Apply Costume Windows XP Theme.

Set OSHApp = CreateObject("Shell.Application")
Set oShell = CreateObject("Wscript.Shell")
oSHApp.ControlPanelItem cstr("desk.cpl desk,@Themes /Action:OpenTheme /file:" ^& """" + "%SystemRoot%\Resources\Themes\blabla.theme" + """")
While OShell.AppActivate ("Display Properties") = FALSE
	Wscript.Sleep 1000
Wend
While OShell.AppActivate ("Display Properties") = TRUE
	oShell.AppActivate "Display Properties"
	Wscript.Sleep 200
	oShell.sendkeys "{ENTER}"
Wend

Edited by Outbreaker
Link to comment
Share on other sites

gunsmokingman

gunsmokingman

Posted
Posted

Here try this

' Apply Costume Windows XP Theme.
 Dim Fso	 :Set Fso = CreateObject("Scripting.FileSystemObject")
 Dim OSHApp  :Set OSHApp = CreateObject("Shell.Application")
 Dim oShell  :Set oShell = CreateObject("Wscript.Shell")
 Dim MyTheme :MyTheme = "%SystemRoot%\Resources\Themes\blabla.theme"
  If Fso.FileExists(MyTheme) Then
   oSHApp.ControlPanelItem cstr("desk.cpl desk,@Themes /Action:OpenTheme /file:" & """" + MyTheme + """")
	While OShell.AppActivate ("Display Properties") = FALSE
	 Wscript.Sleep 1000
	Wend
   While OShell.AppActivate ("Display Properties") = TRUE
	oShell.AppActivate "Display Properties"
	Wscript.Sleep 200
	oShell.sendkeys "{ENTER}"
   Wend
  Else
   MsgBox vbTab & "Error Missing Theme" & vbCrLf & MyTheme,4128, "Error Missing Theme"
  End if

Link to comment
Share on other sites
gunsmokingman

gunsmokingman

Posted
Posted

Try this

' Apply Costume Windows XP Theme.
Dim Fso	 :Set Fso = CreateObject("Scripting.FileSystemObject")
Dim OSHApp  :Set OSHApp = CreateObject("Shell.Application")
Dim oShell  :Set oShell = CreateObject("Wscript.Shell")
Dim MyTheme :MyTheme = oShell.ExpandEnvironmentStrings("%SystemRoot%\Resources\Themes\blabla.theme")
  If Fso.FileExists(MyTheme) Then
   oSHApp.ControlPanelItem cstr("desk.cpl desk,@Themes /Action:OpenTheme /file:" & """" + MyTheme + """")
	While OShell.AppActivate ("Display Properties") = FALSE
	 Wscript.Sleep 1000
	Wend
   While OShell.AppActivate ("Display Properties") = TRUE
	oShell.AppActivate "Display Properties"
	Wscript.Sleep 200
	oShell.sendkeys "{ENTER}"
   Wend
  Else
   MsgBox vbTab & "Error Missing Theme" & vbCrLf & MyTheme,4128, "Error Missing Theme"
  End if

Link to comment
Share on other sites
Outbreaker

Outbreaker

Posted
  • Author
Posted

No also not working :(

If i use:

Start "" /wait "Apply Theme.vbs" "Theme_Name.theme"

or

Start "" /wait "Apply Theme.vbs" "Theme_Name"

Then i get always the error "C:\WINDOWS\Resources\Themes\blabla.theme" is missing.

Should it not be "C:\WINDOWS\Resources\Themes\Theme_Name.theme" is missing ?

Link to comment
Share on other sites
gunsmokingman

gunsmokingman

Posted
Posted

I ran the script and it works fine when I added

Dim MyTheme :MyTheme = oShell.ExpandEnvironmentStrings("%SystemRoot%\Resources\Themes\GsmGrey.Theme")

I do not know how to pass a varible from cmd promt to vbs script.

Here is a vbs script all you have to do is drag a theme file on to it.

Option Explicit
 Dim Act :Set Act = CreateObject("Wscript.Shell")
 Dim Shl :Set Shl = CreateObject("Shell.Application")

   If Wscript.Arguments.Count = 0 Then
	msgbox vbtab & "Error No Drag And Drop" & vbCrLf & _
	"Please Drag And Drop A Theme File On This Script" ,4128,"Error No Drag Drop"
   Else
   Dim Obj
	For Each Obj In WScript.Arguments
	 If Right(InStr(LCase(Obj),Lcase(".Theme")),6) Then 
	 ApplyTheme()
	 End If 
	Next 
   End If

   Function ApplyTheme()
	Shl.ControlPanelItem cstr("desk.cpl desk,@Themes /Action:OpenTheme /file:" & """" + Obj + """")
	While Act.AppActivate ("Display Properties") = False
	 Wscript.Sleep 1000
	Wend
	While Act.AppActivate ("Display Properties") = TRUE
	 Act.AppActivate "Display Properties"
	 Wscript.Sleep 200
	 Act.sendkeys "{ENTER}"
	Wend
   End Function

Link to comment
Share on other sites
hessam

hessam

Posted
Posted
I ran the script and it works fine when I added

Dim MyTheme :MyTheme = oShell.ExpandEnvironmentStrings("%SystemRoot%\Resources\Themes\GsmGrey.Theme")

I do not know how to pass a varible from cmd promt to vbs script.

Here is a vbs script all you have to do is drag a theme file on to it.

Option Explicit
 Dim Act :Set Act = CreateObject("Wscript.Shell")
 Dim Shl :Set Shl = CreateObject("Shell.Application")

   If Wscript.Arguments.Count = 0 Then
	msgbox vbtab & "Error No Drag And Drop" & vbCrLf & _
	"Please Drag And Drop A Theme File On This Script" ,4128,"Error No Drag Drop"
   Else
   Dim Obj
	For Each Obj In WScript.Arguments
	 If Right(InStr(LCase(Obj),Lcase(".Theme")),6) Then 
	 ApplyTheme()
	 End If 
	Next 
   End If

   Function ApplyTheme()
	Shl.ControlPanelItem cstr("desk.cpl desk,@Themes /Action:OpenTheme /file:" & """" + Obj + """")
	While Act.AppActivate ("Display Properties") = False
	 Wscript.Sleep 1000
	Wend
	While Act.AppActivate ("Display Properties") = TRUE
	 Act.AppActivate "Display Properties"
	 Wscript.Sleep 200
	 Act.sendkeys "{ENTER}"
	Wend
   End Function

if you can create js or vbs to automatic set theme without dragdrop

Link to comment
Share on other sites
gunsmokingman

gunsmokingman

Posted
Posted

Here just fill in the required theme path and name and it should work.

Option Explicit
Dim Act :Set Act = CreateObject("Wscript.Shell")
Dim Fso :Set Fso = CreateObject("Scripting.FileSystemObject")
Dim Shl :Set Shl = CreateObject("Shell.Application")
Dim Thm :Thm = Act.ExpandEnvironmentStrings("%Windir%\PATH_TO_THEME\THEME_NAME")

  If Fso.FileExists(Thm) Then
   ApplyTheme()
  Else
   Msgbox("Can Not Find This Theme" & Thm, 4128, "Error No Theme"
  End If 

   Function ApplyTheme()
	Shl.ControlPanelItem cstr("desk.cpl desk,@Themes /Action:OpenTheme /file:" & """" + Thm + """")
	While Act.AppActivate ("Display Properties") = False
	 Wscript.Sleep 1000
	Wend
	While Act.AppActivate ("Display Properties") = TRUE
	 Act.AppActivate "Display Properties"
	 Wscript.Sleep 200
	 Act.sendkeys "{ENTER}"
	Wend
   End Function

Link to comment
Share on other sites
hessam

hessam

Posted
Posted

dont work get error line:10 char:66 error:expected code:800A03EE

Option Explicit
Dim Act :Set Act = CreateObject("Wscript.Shell")
Dim Fso :Set Fso = CreateObject("Scripting.FileSystemObject")
Dim Shl :Set Shl = CreateObject("Shell.Application")
Dim Thm :Thm = Act.ExpandEnvironmentStrings("%Windir%\Resources\Themes\Windows Classic.theme")

  If Fso.FileExists(Thm) Then
   ApplyTheme()
  Else
   Msgbox("Can Not Find This Theme" & Thm, 4128, "Error No Theme"
  End If 

   Function ApplyTheme()
    Shl.ControlPanelItem cstr("desk.cpl desk,@Themes /Action:OpenTheme /file:" & """" + Thm + """")
    While Act.AppActivate ("Display Properties") = False
     Wscript.Sleep 1000
    Wend
    While Act.AppActivate ("Display Properties") = TRUE
     Act.AppActivate "Display Properties"
     Wscript.Sleep 200
     Act.sendkeys "{ENTER}"
    Wend
   End Function

Link to comment
Share on other sites
gunsmokingman

gunsmokingman

Posted
Posted

This is what was causing the mistake

 Msgbox("Can Not Find This Theme" & Thm, 4128, "Error No Theme"

Should be this

 Msgbox "Can Not Find This Theme" & Thm, 4128, "Error No Theme"

Re-writen Code tested 

Option Explicit 
 Dim Act :Set Act = CreateObject("Wscript.Shell")
 Dim Fso :Set Fso = CreateObject("Scripting.FileSystemObject")
 Dim Shl :Set Shl = CreateObject("Shell.Application")
 Dim Thm :Thm = Act.ExpandEnvironmentStrings("%Windir%\Resources\Themes\Windows Classic.theme")

   If Fso.FileExists(Thm) Then   
	ApplyTheme() 
   Else   
	Msgbox "Can Not Find This Theme" & vbCrLf & Thm, 4128, "Error No Theme"
   End If 

   Function ApplyTheme()	
	Shl.ControlPanelItem cstr("desk.cpl desk,@Themes /Action:OpenTheme /file:" & """" + Thm + """")	
	 While Act.AppActivate("Display Properties") = False	 
	   Wscript.Sleep 1000	
	  Wend	
	  While Act.AppActivate("Display Properties") = TRUE	 
	  Act.AppActivate "Display Properties"	 
	  Wscript.Sleep 200	 
	 Act.sendkeys "{ENTER}"	
	Wend   
   End Function

Link to comment
Share on other sites
Outbreaker

Outbreaker

Posted
  • Author
Posted (edited) 

Dim Act :Set Act = CreateObject("Wscript.Shell")
Dim Shl :Set Shl = CreateObject("Shell.Application")

   If Wscript.Arguments.Count = 0 Then
	msgbox vbtab & "Error No Drag And Drop" & vbCrLf & _
	"Please Drag And Drop A Theme File On This Script" ,4128,"Error No Drag Drop"
   Else
   Dim Obj
	For Each Obj In WScript.Arguments
	 If Right(InStr(LCase(Obj),Lcase(".Theme")),6) Then 
	 ApplyTheme()
	 End If 
	Next 
   End If

   Function ApplyTheme()
	Shl.ControlPanelItem cstr("desk.cpl desk,@Themes /Action:OpenTheme /file:" & """" + Obj + """")
	While Act.AppActivate ("Display Properties") = False
	 Wscript.Sleep 1000
	Wend
	While Act.AppActivate ("Display Properties") = TRUE
	 Act.AppActivate "Display Properties"
	 Wscript.Sleep 200
	 Act.sendkeys "{ENTER}"
	Wend
   End Function

Good this dragdrop script will also work whit the CMD-Box like:

"test.vbs" "C:\WINDOWS\Resources\Themes\My_Theme.theme"

Now it would be good if we enter a wrong Theme in the CMD-Box like:

"test.vbs" "C:\WINDOWS\Resources\Themes\My_Theme1.theme"

Then it would be good to get a error message and the script should also stop appying this Theme. :)

Like the error option if you would click on the "test.vbs" file.

Edited by Outbreaker
Link to comment
Share on other sites
gunsmokingman

gunsmokingman

Posted
Posted

This will not apply the luna theme, it is still drag and drop.

Option Explicit
 Dim Act :Set Act = CreateObject("Wscript.Shell")
 Dim Shl :Set Shl = CreateObject("Shell.Application")

   If Wscript.Arguments.Count = 0 Then
	msgbox vbtab & "Error No Drag And Drop" & vbCrLf & _
	"Please Drag And Drop A Theme File On This Script" ,4128,"Error No Drag Drop"
   Else
   Dim Obj
	For Each Obj In WScript.Arguments
	 If Right(InStr(LCase(Obj),Lcase(".Theme")),6) Then 
	  If InStr(LCase(Obj),LCase("Luna")) Then
	   msgbox vbtab & "Error Luna Theme" & vbCrLf & _
	   "This Theme Will Not be Applied, Select Another Theme" ,4128, "Error Luna Theme"
	  Else
	   ApplyTheme()
	  End if
	 End If 
	Next 
   End If

   Function ApplyTheme()
	Shl.ControlPanelItem cstr("desk.cpl desk,@Themes /Action:OpenTheme /file:" & """" + Obj + """")
	While Act.AppActivate ("Display Properties") = False
	  Wscript.Sleep 1000
	 Wend
	 While Act.AppActivate ("Display Properties") = TRUE
	  Act.AppActivate "Display Properties"
	  Wscript.Sleep 200
	 Act.sendkeys "{ENTER}"
	Wend
   End Function

Link to comment
Share on other sites
hessam

hessam

Posted
Posted
This is what was causing the mistake
 Msgbox("Can Not Find This Theme" & Thm, 4128, "Error No Theme"

Should be this

 Msgbox "Can Not Find This Theme" & Thm, 4128, "Error No Theme"

Re-writen Code tested 

Option Explicit 
 Dim Act :Set Act = CreateObject("Wscript.Shell")
 Dim Fso :Set Fso = CreateObject("Scripting.FileSystemObject")
 Dim Shl :Set Shl = CreateObject("Shell.Application")
 Dim Thm :Thm = Act.ExpandEnvironmentStrings("%Windir%\Resources\Themes\Windows Classic.theme")

   If Fso.FileExists(Thm) Then   
	ApplyTheme() 
   Else   
	Msgbox "Can Not Find This Theme" & vbCrLf & Thm, 4128, "Error No Theme"
   End If 

   Function ApplyTheme()	
	Shl.ControlPanelItem cstr("desk.cpl desk,@Themes /Action:OpenTheme /file:" & """" + Thm + """")	
	 While Act.AppActivate("Display Properties") = False	 
	   Wscript.Sleep 1000	
	  Wend	
	  While Act.AppActivate("Display Properties") = TRUE	 
	  Act.AppActivate "Display Properties"	 
	  Wscript.Sleep 200	 
	 Act.sendkeys "{ENTER}"	
	Wend   
   End Function

Thanyou very much great help its working :lol::thumbup

it possible to do not show display propertis

Link to comment
Share on other sites
Outbreaker

Outbreaker

Posted
  • Author
Posted

This would be also handy:

Fortunately there is an alternate solution to this script and its SendKeys: send a BM_CLICK window message to the button we need to press in the required Theme window. This way we can warrantee that we close the right window by pressing the right button.

http://blogs.msdn.com/alejacma/archive/200...ally-in-xp.aspx

Link to comment
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now
 Share
Go to topic listing

  • Recently Browsing   0 members

    • No registered users viewing this page.
×
×
  • Create New...