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
| Option Explicit
Const ContextMenuName = "Créer fichier texte de même nom que la sélection"
Const vbDirectory = 16, vbVolume = 8
Const HKCR = &H80000000 ' HKEY_CLASSES_ROOT
Const REG_SZ = 1
Dim fso, Fich, oArgs, strPath, NewFile, bReplace, objReg
Dim OpenExisting, tmpName, I, WS, ScriptAndOptions, App_Path
App_Path = Wscript.FullName
ScriptAndOptions = " " & Chr(34) & Wscript.ScriptFullName & Chr(34) & " " & Chr(34) & "%1" & Chr(34)
Set WS = CreateObject("Wscript.Shell")
Set oArgs = Wscript.Arguments
'Vérification de la clé du registre concernant le menu contextuel
VerifRegEntry
'Utilisation du menu contextuel
Set fso = CreateObject("Scripting.FileSystemObject")
If oArgs.Length = 0 Then Wscript.Quit
' On traite un ensemble d'éléments sélectionnés(fichiers et/ou dossiers)
' On utilisera le nom du dernier élément de l'arborescence(fichier ou dossier) au format long
For I = 0 To oArgs.Count - 1
If IsFolder(oArgs(I)) Then
strPath = GetShortPath(oArgs(I))
tmpName = fso.GetFolder(oArgs(I)).Name
strPath = fso.GetFolder(strPath).ParentFolder & "\"
NewFile = strPath & tmpName & ".txt"
ElseIf IsFile(oArgs(I)) Then
strPath = GetShortPath(oArgs(I))
strPath = fso.GetFile(strPath).ParentFolder & "\"
NewFile = strPath & fso.GetBaseName(oArgs(I)) & ".txt"
End If
If fso.FileExists(NewFile) Then
If MsgBox("Le fichier " & NewFile & " existe déjà." & vbNewLine _
& vbNewLine & vbTab & "Voulez-vous le remplacer ?", vbYesNo, _
"Remplacer un fichier") = vbNo Then
bReplace = False
OpenExisting = 1
Else
bReplace = True
OpenExisting = 2
End If
Else
bReplace = True
OpenExisting = 2
End If
Set Fich = fso.OpenTextFile(NewFile, OpenExisting, bReplace)
Fich.Close
WS.Run fso.GetFile(NewFile).ShortPath, 1, False
Next
' Clean up environment objects :
Set fso = Nothing : Set Fich = Nothing : Set WS = Nothing : Set oArgs = Nothing
'================================
Sub VerifRegEntry()
Const RAC = "HKCR\Folder\Shell\"
Dim KeyAllFiles, KeyFolders
Dim intFlag1, intFlag2
KeyAllFiles = "HKCR\*\Shell\" & ContextMenuName & "\Command\"
KeyFolders = RAC & ContextMenuName & "\Command\"
intFlag1 = 0 : intFlag2 = 0
With WS
If Not RegEntryExists(HKCR, "*\Shell\", App_Path & ScriptAndOptions) Then
.RegWrite KeyAllFiles, App_Path & ScriptAndOptions
intFlag1 = 1
End If
If Not RegEntryExists(HKCR, "Folder\Shell\", App_Path & ScriptAndOptions) Then
.RegWrite KeyFolders, App_Path & ScriptAndOptions
intFlag2 = 2
End If
End With
' Informations sur l'installation du script
If intFlag1 + intFlag2 >= 1 Then
MsgBox "Installation terminée avec succès(" & intFlag1 + intFlag2 & ")" & vbNewLine & vbNewLine & _
"Ligne de commande : " & vbNewLine & WS.RegRead(KeyAllFiles)
Else
' Installation déjà faite, pas besoin de le mentionner
' sauf si on exécute le sctipt sans arguments
If oArgs.Count = 0 And intFlag1 + intFlag2 = 0 Then MsgBox "Installation déjà faite auparavant !", , "Script installé"
End If
End Sub
'==============================
Function RegEntryExists(sHive, sEnumPath, MenuData)
Dim lRC, ValueExists
Dim wmiLocator, wshNetwork, wmiNameSpace, Mycomputer
Dim sNames, sKeyName, IsThere
IsThere = False
Set wmiLocator = CreateObject("WbemScripting.SWbemLocator")
Set wshNetwork = CreateObject("WScript.Network")
Mycomputer = wshNetwork.ComputerName
Set wmiNameSpace = wmiLocator.ConnectServer(Mycomputer, "root\default")
Set objReg = wmiNameSpace.Get("StdRegProv")
lRC = objReg.EnumKey(sHive, sEnumPath, sNames)
For Each sKeyName In sNames
If sKeyName = ContextMenuName Then
IsThere = True
Exit For
End If
Next
If IsThere Then
Dim bExiste, lRet1, lRet2, sValue , strFullRegPath
strFullRegPath = sEnumPath & ContextMenuName & "\Command\"
lRet1 = objReg.EnumValues(HKCR, strFullRegPath, "", REG_SZ)
lRet2 = objReg.GetStringValue(HKCR, strFullRegPath, "", sValue)
bExiste = (sValue = MenuData )
End If
RegEntryExists = bExiste And IsThere ': MsgBox bExiste And IsThere
End Function
'=======================
Function GetShortPath(strElem)
Dim f', fso
'Set fso = CreateObject("Scripting.FileSystemObject")
If IsFolder(strElem) Then
GetShortPath = fso.GetFolder(strElem).ShortPath
ElseIf IsFile(strElem) Then
GetShortPath = fso.GetFile(strElem).ShortPath
End If
End Function
'===========================
Function IsFolder(strElement)
Dim Attr, F', fso
'Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set F = fso.GetFolder(strElement)
IsFolder = ((F.Attributes And vbDirectory) = vbDirectory)
' Set fso = Nothing
End Function
'============================
Function IsFile(strElement)
Dim F ', fso
'Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set F = fso.GetFile(strElement)
IsFile = ((F.Attributes And vbDirectory) <> vbDirectory or vbVolume)
'Set fso = Nothing
End Function |
Script vbs permettant de créer un fichier txt automatiquement sur click bouton droit autre fichier (jpg, etc)
)
Répondre avec citation
Ne pas oublier le tag 
si satisfait.
Voter pour toute réponse satisfaisante avec 
pour encourager les intervenants.
Ooops! Rien ne se produit après double click.
Partager