Changement fond écran

**sovan** · 03/10/2013, 15h33

Bonjour,

J'ai fait un script HTA pour changer fond écran !!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
 
'Bouton 	
<INPUT TYPE=""file"" NAME=""inFichier"" SIZE="30" STYLE="HEIGHT:25;WIDTH:300" onChange="fichecran">
 
<INPUT TYPE="BUTTON" STYLE="HEIGHT:25;WIDTH:165" ONCLICK=""Ecran()"" VALUE="Appliquer">
 
 
 'Programe changement écran
SUB Ecran
NewWallPaper = fichecran.value
Set WshShell = CreateObject("WScript.Shell")
MsgBox WshShell.RegRead("HKEY_CURRENT_USER\Control Panel\desktop\Wallpaper")
WshShell.RegWrite "HKEY_CURRENT_USER\Control Panel\desktop\Wallpaper", NewWallPaper
Set WshShell = Nothing 
END SUB

Je n'arrive pas a récupérer le variable de lien de l'image !!

Aidez moi Svp

Je vous remercie d'avance

**hackoofr** · 05/10/2013, 07h29

Bonté divine !. tu m'as fait pondre un code
A tester sur Windows 7 (32 bits) avec UAC désactivé

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
<html>
<head>
<title>Application pour changer le fond d'écran dans Windows 7 © Hackoo © 2013</title>
<HTA:APPLICATION
APPLICATIONNAME="Application pour changer le fond d'écran dans Windows 7"
ID="Application pour changer le fond d'écran dans Windows 7"
ICON="Explorer.exe"
BORDER="dialog"
INNERBORDER="no"
MAXIMIZEBUTTON="No"
SCROLL="no"
VERSION="1.0"/>
<style>
Label
{
color : #123456;
font-family : "Courrier New";
}
BODY {background-color:lightcyan;}
input.button {  background-color : #EFEFEF;
color : #000000; cursor:hand;
font-size: 11px; font-family: Verdana, Arial, Helvetica, sans-serif; }
}
.alt2, .alt2Active
{
background: #E1E4F2;
color: #000000;
}    
</style>
</head>
<META HTTP-EQUIV="MSThemeCompatible" CONTENT="YES">
<script language="VBScript">
Option Explicit
Dim Titre,fso,MyFolder,TabFolder,DossierCourant,DossierCourantIMAGE
Titre = "Application pour changer le fond d'écran dans Windows 7 © Hackoo © 2013"
set fso = CreateObject("Scripting.FileSystemObject")
MyFolder = fso.GetAbsolutePathName(".")
TabFolder = Split(MyFolder,"\")
DossierCourant = TabFolder(UBound(TabFolder))
DossierCourantIMAGE = DossierCourant&"_IMAGE_FOND"
If Not fso.FolderExists(DossierCourantIMAGE) Then
    CreateFolder(DossierCourantIMAGE)
End if 
'*****************************************************************
Sub Window_OnLoad
    CenterWindow 640,200
End Sub
'*****************************************************************
Sub CenterWindow(x,y)
    Dim iLeft,itop
    window.resizeTo x, y
    iLeft = window.screen.availWidth/2 - x/2
    itop = window.screen.availHeight/2 - y/2
    window.moveTo ileft, itop
End Sub 
'*****************************************************************
Sub OnClickButtonCancel()
    Window.Close
End Sub
'*****************************************************************
Function DblQuote(strIn)
    DblQuote = Chr(34) & strIn & Chr(34)
End Function
'*****************************************************************
Sub CreateFolder(strPath)
    set fso = CreateObject("Scripting.FileSystemObject")
    If strPath <> "" Then 
        If Not fso.FolderExists(fso.GetParentFolderName(strPath)) then Call CreateFolder(fso.GetParentFolderName(strPath))
        fso.CreateFolder(strPath)
    End If
End Sub 
'*****************************************************************
SUB ChangeFondEcran()
    Dim MyNewWallPaper,NomMyNewWallPaper,NewWallPaperName,WshShell,MonFondEcranBDR,CheminAncienWallpaper,i,MonTab,Destination
    Set WshShell = CreateObject("WScript.Shell")
    MonFondEcranBDR = "HKEY_CURRENT_USER\Control Panel\desktop\Wallpaper"
    CheminAncienWallpaper = WshShell.RegRead(MonFondEcranBDR)
    MsgBox CheminAncienWallpaper,64,Titre
'Copie de Sauvegarde de l'ancien Wallpaper
    Call CopyFile(CheminAncienWallpaper,DossierCourantIMAGE)
    MyNewWallPaper = fichecran.Value
    NomMyNewWallPaper = Split(MyNewWallPaper,"\")
    NewWallPaperName = NomMyNewWallPaper(UBound(NomMyNewWallPaper))
    'MsgBox MyNewWallPaper,64,Titre
    If MyNewWallPaper <> "" Then
        MonTab = Split(CheminAncienWallpaper,"\")
        Destination = ""
        For i = LBound(MonTab) To UBound(MonTab) - 1
            Destination = Destination + MonTab(i) + "\"
        Next
        'MsgBox Destination,64,Titre
'Supprimer l'ancien Wallpaper
        Call DeleteMyOldFile(CheminAncienWallpaper)
        Call CopyFile(MyNewWallPaper,Destination)
        Call Renommer(Destination & NewWallPaperName,MonTab(UBound(MonTab)))
        RefreshExplorer()
    End if
    Set WshShell = Nothing 
END Sub
'*****************************************************************
Function CopyFile(Source,Destination)
    Dim  FSO
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(Destination) Then
        If Right(Destination,1) <> "\" Then
            Destination = Destination & "\"
        End if
        FSO.GetFile(Source).Copy Destination & FSO.GetFileName(Source),True
        MsgBox "Copie du fond d'écran : " & DblQuote(FSO.GetFileName(Source)) & " dans le dossier " & DblQuote(Destination),64,Titre
    Else 
        MsgBox DblQuote(Destination) & " n'existe pas !",48,Titre
    End If
End Function
'*****************************************************************
'Fonction pour écrire le résultat dans un fichier texte
Sub WriteLog(strText,LogFile)
    Dim fs,ts 
    Const ForAppending = 8
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set ts = fs.OpenTextFile(LogFile,ForAppending,True)
    ts.WriteLine strText
    ts.Close
End Sub
'*****************************************************************
Function DeleteMyOldFile(Source)
    Dim  FSO
    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(Source) Then
        FSO.GetFile(Source).Delete False
    End If
End Function
'******************************************************************
Function Renommer(Fichier1,Fichier2)
    Dim Ws,Command,Execution
    Set Ws = CreateObject("WScript.Shell")
    Command = "Cmd /C Ren "&Fichier1&","&Fichier2&""
    Execution = Ws.Run(Command,0,True)
End Function
'******************************************************************
Sub Kill(Process)
Dim Ws,Command,Execution
    Set Ws = CreateObject("WScript.Shell")
    Command = "cmd /c Taskkill /F /IM "&Process&""
    Execution = Ws.Run(Command,0,True)
End Sub
'*****************************************************************
Sub Start(Process)
Dim Ws,Command,Execution
    Set Ws = CreateObject("WScript.Shell")
    Command = "cmd /c Start "&Process&""
    Execution = Ws.Run(Command,0,True)
End Sub
'*****************************************************************
Sub RefreshExplorer()
     Kill("Explorer.exe")
     Start("Explorer.exe")
End Sub
</script>
<center>
<B>Veuillez choisir l'image pour changer le fond d'écran </B><br><br>
<input type="file" size="50" name="fichecran" style="font-weight: bold; id="file1" />
<br><br><br>
<input type="Submit" style="width: 180px" style="font-weight: bold; name="OK" id="OK" value="Changer le fond d'écran" onclick="ChangeFondEcran()">
<input type="button" style="width: 100px" style="font-weight: bold; name="Cancel" id="Cancel" value="Sortir" onclick="OnClickButtonCancel"><br><br>
</body>
</html>

**sovan** · 07/10/2013, 12h07

Héhé MERCI

hackoofr

Je vais tester ça

**sovan** · 19/10/2013, 11h34

J'ai testé ton code hackoofr , mais ça ne fonction pas sur mon pc.

J'ai du mal à décoder ton code pour comment ça fonction le changement d'écran.

Pourras tu m'expliquer en détail juste le fonctionnement changement fond écran ?

Tu te demande pourquoi je voulais changer absolument le fond écran.

En fait ma boite est en pleine migration Windows 7(64bits), l'administrateur de ma boite, bloque les accès avec le GPO.

Je voudrais savoir si c'est possible de changer fond écran avec login et mdp de l'administrateur local ?

Merci de réponse !

**hackoofr** · 19/10/2013, 13h05

Bon, si tu as des restrictions ==> impossible de faire fonctionner ce code Dommage

Essaies de l'exécuter sur un système WIN 7 (32bits) qui a les droits administrateur avec UAC désactivé ou bien sur un Win XP

Changement fond écran

VBScript

Discussions similaires

Partager

Partager