WSH（VBScript）：Windows 7“新建文件”上下文菜单项

Posted 2021-02-26

A modification of Bill James' New Folder context menu script ( http://billsway.com/vbspage/ ), this script instead creates a "New File" item in the right click context menu of Directory Backgrounds. Upon running the New File item, you will be prompted for a filename that defaults to "new.txt". Once a valid filename has been entered (not an existing file) the script will then create the file. This allows the filename to be chosen in the dialog before any file creation has been executed. This has been tested to work on Windows 7 but may work on Vista as well.

Make the code below into a vbs file in the location you want it to be installed in (eg. C:WindowsNewFile.vbs). To install the context menu item, run the vbs file. To uninstall the file, run the vbs file again.

' NewFile.vbs - Create right click context menu item for drives and
' directories (folders) allowing the creation of a new file.
' To Install or Un-install, double click this file.
 
' Requires WSH 2.0 +
 
' Original New Folder script ���© Bill James - [email protected] - rev 14/Nov/2001
' http://billsway.com/vbspage/
 
' New File Revision by Karl Horky
' v0.1 05 April 2010
 
Option Explicit
Dim fso, ws, Args, Title
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("Wscript.Shell")
Set Args = WScript.Arguments
Title = "Create New File Tool"
 
'Validate correct version for script.
If WScript.Version < 5.1 Then
  ws.Popup "You need Windows Script Host 2.0 + to " & _
           "run this script.", , Title, 0 + 48 + 4096
  Call Cleanup
End If
 
'If script called directly, check setup & uninstall.
If Args.Count = 0 Then
  Call Setup
End If
 
'Disable multiple drag and drop
If Args.Count > 1 Then
  Call Cleanup
End If
 
Dim ParentFldr
'If a file was dragged to script, exit
On Error Resume Next
Set ParentFldr = fso.GetFile(Args(0))
If Err.Number = 0 Then
  Call Cleanup
End If
Set ParentFldr = Nothing
On Error GoTo 0
 
Call MakeNewFile
 
Call Cleanup
 
Sub MakeNewFile
  Dim NewFile, DirectoryPath, NewFilePath
  NewFile = InputBox("Name for New File?", Title, "new.txt")
  If NewFile = "" Then Call Cleanup
  On Error Resume Next
  DirectoryPath = fso.GetFolder(Args(0))
  If Right(DirectoryPath,1)<>"" Then DirectoryPath = DirectoryPath & ""
  NewFilePath = DirectoryPath & NewFile
  If fso.FileExists(NewFilePath)=true Then
    ws.Popup Chr(34) & NewFilePath & Chr(34) & " already exists.", ,Title, 0 + 48 + 4096
    Call MakeNewFile
  Else
    fso.CreateTextFile NewFilePath
    If Err.Number = 58 Then
      Err.Clear:On Error GoTo 0
      ws.Popup Chr(34) & NewFile & Chr(34) & " already exists.", ,Title, 0 + 48 + 4096
      Call MakeNewFile
    ElseIf Err.Number = 52 Then
      Err.Clear:On Error GoTo 0
      ws.Popup Chr(34) & NewFile & Chr(34) & " contains invalid character(s).", ,Title, 0 + 48 + 4096
      Call MakeNewFile
    End If
  End If
End Sub
 
Sub Setup
  'Write Reg Data if not existing or if path is invalid.
  Dim p
  On Error Resume Next
  p = ws.RegRead("HKCRDirectoryBackgroundshellNewFile (*)command")
  p = Mid(p, 10, Len(p) - 15)
  Err.Clear:On Error GoTo 0
  If NOT fso.FileExists(p) Then
    If ws.Popup("Do you want to Install the Folder context menu for " & _
                "creating a new file?", , Title, 4 + 32 + 4096) <> 6 Then
      Call Cleanup
    End If
    ws.RegWrite "HKCRDirectoryBackgroundshellNewFile (*)","&New File"
    ws.RegWrite "HKCRDirectoryBackgroundshellNewFile (*)command", _
      "WScript " & chr(34) & WScript.ScriptFullName & _
      chr(34) & " " & chr(34) & "%V" & chr(34)
    ws.Popup "Setup complete.  Right click on any Directory Background in Windows " & _
             "Explorer and select the " & chr(34) & "New File" & chr(34) & _
             " option to create a new file there." & vbcrlf & vbcrlf & _
             "To Un-install, run this script again.", , Title, 64 + 4096
  Else
    If ws.Popup("Do you want to Un-install the Folder context menu for " & _
                "creating a new file?", , Title, 4 + 32 + 4096) <> 6 Then
      Call Cleanup
    End If
      ws.RegDelete "HKCRDirectoryBackgroundshellNewFile (*)command"
      ws.RegDelete "HKCRDirectoryBackgroundshellNewFile (*)"
    ws.Popup "Un-install complete.", , Title, 64 + 4096
  End If
  Call Cleanup
End Sub
 
Sub Cleanup
  Set ws = Nothing
  Set fso = Nothing
  Set Args = Nothing
  WScript.Quit
End Sub