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 |