Script vbs permettant de créer un fichier txt automatiquement sur click bouton droit autre fichier (jpg, etc)

**nmuire** · 17/06/2019, 18h28

Bonjour,
Help!

Il y a quelques années j'utilisais un script vbs co-rédigé par le gestionnaire du site http://julotsoft.free.fr.
Voici son principe :
' Script permettant avec un clic-droit
' sur un fichier ou un dossier quelconque dans l'explorateur Windows,
' de créer automatiquement un fichier texte de même mon.
' ex: toto.jpg -> toto.txt
http://julotsoft.free.fr/spip.php?article20

Sur Win10, jusqu'à la version 1809 pas de souci. Mais depuis la version 1903... Dans le menu contextuel de l'explorateur, je ne retrouve plus le raccourci qui permettait ce "tour de magie" - permettant de créer un fichier txt portant le même nom que celui-ci sur lequel on se trouve.

J'ai le script initial.
Est-ce quelqu'un a une idée, pourrait revoir ce code ou donner un truc pour que cela refonctionne? Cela serait top!
Je n'y connais pas grand chose en programmation. (Ce n'est pas mes quelques notions de php qui m'aideront ici

)

Un grand merci d'avance à la bonne âme qui pourra m'aider!!!

Bonne journée!

**l_autodidacte** · 17/06/2019, 23h31

Salut et BIENVENU sur DVP

Puisque tu disposes du script d'origine, il serait d'un grand secours qu'on le voit pour essayer de t'aider.

**l_autodidacte** · 18/06/2019, 01h34

Sans voir ton code, j'ai pu en créer un qui fait le boulot souhaité.

Une première exécution sans arguments est nécessaire pour faire apparaitre le menu contextuel voulu.
Le script peut être placé n'importe où et il saura mettre à jour son chemin dans la base du registre.

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
Option Explicit 
 
Dim fso, Fich, oArgs, strPath, NewFile, bReplace, OpenExisting
 
'Vérification de la clé du registre concernant le menu contextuel
  VerifRegEntry
'Utilisation du menu contextuel
Set fso = CreateObject("Scripting.FileSystemObject") 
Set oArgs = Wscript.Arguments
 
If oArgs.Length = 0 Then Wscript.Quit
'If LCase(fso.GetExtensionName(oArgs(0))) ="jpg" Then ' si uniquement pour fichier jpg
    strPath = fso.GetFile(fso.GetFile(oArgs(0)).ShortPath).ParentFolder & "\"  
    NewFile = strPath & "\" & fso.GetBaseName(fso.GetFile(oArgs(0)).Path) & ".txt" 
    If fso.FileExists(NewFile) Then 
       If MsgBox("Le fichier " & NewFile & " existe," & vbNewLine & "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
'End If
'================================
Sub VerifRegEntry()
 
   Const ContextMenuName = "Créer fichier texte de même nom que la sélection"
 
   Dim WS, App_Path, Key
   Key = "HKCR\*\Shell\" & ContextMenuName & "\Command\"
   Set WS = CreateObject("Wscript.Shell")
   App_Path = Wscript.FullName
 
   With WS
      On Error Resume Next ' nécessaire car si la clé n'existe pas, il y a erreur.
      If .RegRead(Key) = "" Or _
         .RegRead(Key) <> App_Path & " " & Chr(34) & Wscript.ScriptFullName & Chr(34)  & " " & Chr(34) & "%1" & Chr(34) Then
              .RegWrite Key, App_Path & " " & Chr(34) & Wscript.ScriptFullName & Chr(34) & " " & Chr(34) & "%1" & Chr(34)
      Else
        Exit Sub
      End If
   End With
   Set WS = Nothing
End Sub

**nmuire** · 18/06/2019, 16h05

Voici le code du fichier dont je parlais au départ :

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
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
 
Option Explicit
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'               Script :    fichier-dossier+txt.vbs
'               Version : 1.0
'               Date : 2/09/2004
'               <a href="http://julotsoft.free.fr" target="_blank">http://julotsoft.free.fr</a>
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'Script recevant par clic-droit (Explorateur Windows) ou un glisser-déposer,
'en argument un fichier ou un dossier,
'de créer automatiquement un fichier texte de même mon.
' ex:   toto.jpg -> toto.txt
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 
'Déclaration générale
dim fso
Set fso=CreateObject("Scripting.FileSystemObject")
Dim shell
Set shell = WScript.CreateObject("WScript.Shell")
Dim objArgs, shortFilePath, gszlongFilePath, gszChemin
dim gszNomCourtSansExt, gszNomCourtIndex, gszNomCourt, szExt
const gszTITLE="Fichier-Dossier+txt"
dim giIndex
giIndex=0
 
 
'récupération de l'emplacement du fichier sélectionné dans l'explorateur
set objArgs=WScript.Arguments
 
If objArgs.Count=0 Then
  Msgbox "Pour utiliser le créateur de fichier-dossier+txt," & vbLF & _
        "cliquez-droit sur un fichier dans l'Explorateur Windows,", 64, gszTITLE
  WScript.Quit
End if
 
'portion code from Mickaël Harris (MVP Microsoft Scripting)
shortFilePath=objArgs(0)
With WScript.CreateObject("WScript.Shell").CreateShortcut("anyfile.lnk")
  .TargetPath = shortFilePath
  gszlongFilePath = .TargetPath 'on le nom long
End With
'end of Mickaël Harris contribution
 
 
gszChemin= ExtractFilePath(gszlongFilePath)
szExt=fso.GetExtensionName(gszlongFilePath) 'renvoie "" si dossier
gszNomCourt=ExtractFileName(gszlongFilePath)
 
if  szExt="" then ' "Dossier"
        gszNomCourtSansExt=gszNomCourt
else '  "Fichier"
        gszNomCourtSansExt=ExtractFileSimpleName(gszlongFilePath)
end if
'ici on a : gszNomCourtSansExt et le chemin : gszChemin
 
 
Call  ProcNouvTxt
 
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'               Procédure principale
'
'       Lance la création d'un fichier *.txt avec le nom du fichier
'       Lance la vrai gestion d'erreur
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ProcNouvTxt()
        dim bRetour
 
        gszNomCourtIndex=gszNomCourtSansExt & szFoncIndex(giIndex)
        bRetour=bCreationFichierTxt(gszChemin,gszNomCourtIndex,False)
        ActionSuivre(bRetour)
 
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'       Après la création, VRAI gestion de l'erreur
'
'       l'argument est ce qui est renvoyé par la création du fichier texte
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub ActionSuivre(bCas)
        Dim iMsg, bRetour
 
        Select Case bCas
                'Case 1 'tout va bien
                Case 2 'erreur inconnue
                Msgbox "Il y a eu l'erreur : " & Err.Description , 64, gszTITLE
 
                Case 0 'fixé déjà existant
                iMsg=Msgbox("Le fichier : " &  gszNomCourtIndex & ".txt" & _
                        " existe déjà." & vbNewline & vbNewline & _
                        "Voulez-vous :" & vbNewline & _
                        "- Créer un fichier : " & gszNomCourtSansExt &_
                        szFoncIndex(giIndex+1) & ".txt  (Oui)" & vbNewline & _
                        "- Ecraser le fichier : " & gszNomCourtIndex &_
                        ".txt  (Non)" & vbNewline & _
                        "- Annuler l'opération  (Annuler)",vbYesNoCancel+vbQuestion,gszTITLE)
                if iMsg=2 Then Exit Sub 'vbCancel
                if iMsg=6 Then' vbYes +1
                        giIndex=giIndex+1
                        gszNomCourtIndex=gszNomCourtSansExt & szFoncIndex(giIndex)
                        bRetour=bCreationFichierTxt _
                                (gszChemin,gszNomCourtIndex,False)
                        ActionSuivre(bRetour)
                End If
                if iMsg=7 Then 'vbNo Ecrasement
                         bRetour=bCreationFichierTxt _
                                (gszChemin,gszNomCourtIndex,True)
                        ActionSuivre(bRetour)
                End If
 
        End Select
End Sub
 
'===========================================================================
'Fonction de création du fichier .txt
'Gestion interne de l'erreur de création de fichier
'Retour :       0 si le fichier existe déjà
'               1 si l'opération se passe bien + ouverture du fichier
'               2 si une autre erreur
'===========================================================================
Function bCreationFichierTxt(szLechemin,szNomCourt,bEcrasement)
        dim MyFile, commande
        On Error Resume Next
        set MyFile=fso.CreateTextFile(szLeChemin+szNomCourt & ".txt", bEcrasement)
 
        If Err.Number=58 then 'déjà le fichier
                bCreationFichierTxt=0
                Exit Function
        End if
        if Err.Number<>0 then
                bCreationFichierTxt=2 'autre erreur
                exit function
        end if
 
        bCreationFichierTxt=1 'tout va bien
        MyFile.Close
 
        commande=shell.ExpandEnvironmentStrings("%windir%\notepad.exe" &_
                " " & Chr(34) & szLeChemin & szNomCourt & ".txt" & Chr(34))
        shell.Run commande, 1
End Function
 
'===========================================================================
'       Fonction szFoncIndex
'argument : un integer :iindex
'retour : un string qui pour iindex=0 vaut ""
'               et pour les autres vaut "_" + iindex
'===========================================================================
Function szFoncIndex(iindex)
        if iindex=0 then
                szFoncIndex=""
        else
                szFoncIndex="_" & CStr(iindex)
        end if
End Function
 
 
'===========================================================================
'                          ExtractFileName
' VBS Factory Library - (c) 2003 Astase - <a href="http://www.astase.com" target="_blank">www.astase.com</a>
'---------------------------------------------------------------------------
'Usage :  Renvoie le nom du fichier à partir d'un chemin d'accès donné
'============================================================================
Function ExtractFileName(File)
  Dim PathToFile
  PathToFile = File
  If Trim(PathToFile)="" Then PathToFile=Wscript.ScriptFullName
  ExtractFileName = Trim(Mid(PathToFile,Len(Left(PathToFile, InStrRev(PathToFile, "\")))+1))
End Function
 
'===========================================================================
'                          ExtractFileSimpleName
' VBS Factory Library - (c) 2003 Astase - <a href="http://www.astase.com" target="_blank">www.astase.com</a>
'---------------------------------------------------------------------------
'Usage :  Renvoie le nom d'un fichier sans son extension
'Requiert ExtractFileName.
'============================================================================
Function ExtractFileSimpleName(File)
  Dim PathToFile
  PathToFile = File
  If Trim(PathToFile)="" Then PathToFile=Wscript.ScriptFullName
  If InStr(PathToFile,"\")<>0 Then PathToFile=ExtractFileName(PathToFile)
  ExtractFileSimpleName = Trim(Left(PathToFile, InStrRev(PathToFile, ".")-1))
End Function
 
'===========================================================================
'                          ExtractFilePath
' VBS Factory Library - (c) 2003 Astase - <a href="http://www.astase.com" target="_blank">www.astase.com</a>
'---------------------------------------------------------------------------
'Usage :  Renvoie le répertoire parent au fichier passé en paramètre
'============================================================================
Function ExtractFilePath(File)
  Dim PathToFile
  PathToFile = File
  If Trim(PathToFile)="" Then PathToFile=Wscript.ScriptFullName
  ExtractFilePath = Trim(Left(PathToFile, InStrRev(PathToFile, "\")))
End Function

**nmuire** · 18/06/2019, 16h11

Un truc idiot que je n'ai pas essayé avant de vous ennuyer avec mes histoires c'était de désinstaller et réinstaller (.exe) le script... évidemment, après ça refonctionne!!!
Néanmoins, comment dois-je procéder pour tester le tien @l_autodidacte? Faut compiler?
J'avais prévenu... vbs et moi... cela fait 2!

**l_autodidacte** · 18/06/2019, 18h33

Je l'ai déjà signalé dans le post #3 : "Une première exécution du script sans arguments est nécessaire pour faire apparaitre le menu contextuel voulu.
Le script peut être placé n'importe où et il saura mettre à jour son chemin dans la base du registre"
sauf que je n'ai traité que le cas des fichiers.
Pour un dossier, ce sera simple en s'inspirant du code pour un fichier.

Script vbs permettant de créer un fichier txt automatiquement sur click bouton droit autre fichier (jpg, etc)

VBScript

Vue hybride

Discussions similaires

Partager

Partager