HOME > エクセルVBA > サンプル > WSH

WSH


【ファイル名】WSH.xlsm
【バージョン】Ver 1.0.2
【作成日】2015年02月08日
【更新日】2021年04月18日
【動作確認】Windows 7
【必要なソフト】Microsoft Excel 2010
【ダウンロード】WSH.zip
【説明】WSHのサンプルです。

WSHについてはマイクロソフトのサイトのWindows Script Hostリファレンスを参照してください。

動的にFileSystemObjectを使用するには、下記のようにします。
  Dim FSO
  Set FSO = CreateObject("Scripting.FileSystemObject")

VBEの「ツール」の「参照設定」メニューで「Microsoft Scripting Runtime」か「Windows Script Host Object Model」を追加しても良いです。
「Microsoft Scripting Runtime」は、「Scripting」です。
  Dim FSO As New Scripting.FileSystemObject
  MsgBox Prompt:=FSO.GetFileName("C:\windows\notepad.exe")
ライブラリを参照して型を宣言すると、変数とドット記号を入力した後でリストが表示されます。
入力支援

「Windows Script Host Object Model」は、「IWshRuntimeLibrary」です。
  Dim FSO As New IWshRuntimeLibrary.FileSystemObject
  MsgBox Prompt:=FSO.GetBaseName("C:\windows\notepad.exe")

このサンプルは、Application.MacroOptionsで関数の挿入のダイアログに表示されます。
関数の挿入のダイアログ

DriveModule
' DriveModule
Option Explicit
Option Base 1
Option Compare Binary
' ドライブが存在するか?
Public Function DriveExists(Optional DriveName As String) As Boolean
  Dim FSO

  If DriveName = "" Then DriveName = Left(CurDir, 1)
  Set FSO = CreateObject("Scripting.FileSystemObject")
  DriveExists = FSO.DriveExists(DriveName)
  Set FSO = Nothing
End Function
' ドライブ名を取得します。
Public Function GetDriveName(Name As String) As String
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  GetDriveName = FSO.GetDriveName(Name) ' 例 C:
  Set FSO = Nothing
End Function
' ドライブのタイプ(数字)を取得します。
Public Function GetDriveType(DriveName) As Integer
  Dim FSO

  On Error Resume Next
  Set FSO = CreateObject("Scripting.FileSystemObject")
  GetDriveType = FSO.GetDrive(DriveName).DriveType
  Set FSO = Nothing
  On Error GoTo 0
End Function
' ドライブのタイプの名前を取得します。
Public Function GetDriveTypeName(DriveName) As String
  Dim FSO

  On Error Resume Next
  GetDriveTypeName = "なし"
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Select Case FSO.GetDrive(DriveName).DriveType ' 【注意】ドライブは存在しなければいけない!
    Case 0: GetDriveTypeName = "不明"
    Case 1: GetDriveTypeName = "リムーバブルディスク"
    Case 2: GetDriveTypeName = "ハードディスク"
    Case 3: GetDriveTypeName = "ネットワークドライブ"
    Case 4: GetDriveTypeName = "DVDかCD-ROMドライブ"
    Case 5: GetDriveTypeName = "RAMディスク"
  End Select
  Set FSO = Nothing
  On Error GoTo 0
End Function
' ドライブにディスク(DVDなど)がセットされているか?
Public Function IsDriveReady(DriveName As String) As Boolean
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  IsDriveReady = FSO.GetDrive(DriveName).IsReady
  Set FSO = Nothing
End Function

このページの上

FolderModule
' FolderModule
Option Explicit
Option Base 1
Option Compare Binary
' フォルダが存在するか?
Public Function FolderExists(FolderName As String) As Boolean
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  FolderExists = FSO.FolderExists(FolderName)
  Set FSO = Nothing
End Function
' フォルダ名を取得します。
Public Function GetParentFolderName(Name As String) As String
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  GetParentFolderName = FSO.GetParentFolderName(Name)
  Set FSO = Nothing
End Function
' フォルダを削除します。(force = Trueの場合は読み取り専用のフォルダも削除します)
Public Sub DeleteFolder(Name As String, Optional force = False)
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  FSO.DeleteFolder Name, force
  Set FSO = Nothing
End Sub
' フォルダをコピーします。(Overwrite = Trueの場合は上書きコピーします)
' Source・・・コピー元のフォルダ(ワイルドカード文字は可能)
' Destination・・・コピー先のフォルダ(ワイルドカード文字は不可)
' Overwrite・・・Trueの場合は上書きコピーします
Public Sub CopyFolder(Source, Destination As String, Optional Overwrite = True)
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  FSO.CopyFolder Source, Destination, Overwrite
  Set FSO = Nothing
End Sub
' フォルダを移動します。
' Source・・・移動元のフォルダ(ワイルドカード文字は可能)
' Destination・・・移動先のフォルダ(ワイルドカード文字は不可)
Public Sub MoveFolder(Source, Destination As String)
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  FSO.MoveFolder Source, Destination
  Set FSO = Nothing
End Sub

このページの上

FileModule
' FileModule
Option Explicit
Option Base 1
Option Compare Binary
' ファイルが存在するか?
Public Function FileExists(FileName As String) As Boolean
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  FileExists = FSO.FileExists(FileName)
  Set FSO = Nothing
End Function
' ファイルを削除します。(force = Trueの場合は読み取り専用のファイルも削除します)
Public Sub DeleteFile(Name As String, Optional force = False)
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  FSO.DeleteFile Name, force
  Set FSO = Nothing
End Sub
' ファイルをコピーします。(Overwrite = Trueの場合は上書きコピーします)
' Source・・・コピー元のファイル(ワイルドカード文字は可能)
' Destination・・・コピー先のファイル(ワイルドカード文字は不可)
' Overwrite・・・Trueの場合は上書きコピーします
Public Sub CopyFile(Source, Destination As String, Optional Overwrite = True)
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  FSO.CopyFile Source, Destination, Overwrite
  Set FSO = Nothing
End Sub
' ファイルを移動します。
' Source・・・移動元のファイル(ワイルドカード文字は可能)
' Destination・・・移動先のファイル(ワイルドカード文字は不可)
Public Sub MoveFile(Source, Destination As String)
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  FSO.MoveFile Source, Destination
  Set FSO = Nothing
End Sub
' ファイル名を取得します。
Public Function GetFileName(Name As String) As String
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  GetFileName = FSO.GetFileName(Name)
  Set FSO = Nothing
End Function
' ファイルの拡張子を除いたベース名を取得します。
Public Function GetBaseName(Name As String) As String
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  GetBaseName = FSO.GetBaseName(Name)
  Set FSO = Nothing
End Function
 ' ファイルの拡張子を取得します。(ドット「.」は除く)
Public Function GetExtensionName(Name As String) As String
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  GetExtensionName = FSO.GetExtensionName(Name)
  Set FSO = Nothing
End Function
' カレントディレクトリから指定したパスの絶対パス名を返します。
Public Function GetAbsolutePathName(Name As String) As String
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  GetAbsolutePathName = FSO.GetAbsolutePathName(Name)
  Set FSO = Nothing
End Function
' ランダムなファイル名を取得します。
Public Function GetTempName() As String
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  GetTempName = FSO.GetTempName()
  Set FSO = Nothing
End Function
' パスの末尾に名前を追加して返します。
Public Function BuildPath(Path, Name As String) As String
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  BuildPath = FSO.BuildPath(Path, Name)
  Set FSO = Nothing
End Function
' ショートカットのファイルの作成(拡張子は.lnk)
Public Sub CreateShortcut(LinkFileName, TargetPath As String, Optional WindowStyle As Long = 1, _
                  Optional Description As String = "", Optional WorkingDirectory As String = "", _
                  Optional Hotkey As String = "", Optional IconLocation As String = "")
' TargetFile ショートカットの実行可能ファイルへのパス名
' WindowStyle = 1 ウィンドウをアクティブにして表示します。
' WindowStyle = 3 ウィンドウを最大化して表示します。
' WindowStyle = 7 ウィンドウを最小化します。
  Dim WS
  Dim Link

  Set WS = CreateObject("WScript.Shell")
  Set Link = WS.CreateShortcut(LinkFileName)
  Link.TargetPath = TargetPath
  Link.WindowStyle = WindowStyle
  Link.Description = Description
  Link.WorkingDirectory = WorkingDirectory
  Link.Hotkey = Hotkey
  If IconLocation <> "" Then Link.IconLocation = IconLocation
  Link.Save
  Set WS = Nothing
End Sub

このページの上

SpecialFoldersModule
特殊フォルダのNamespaceの列挙は下記のマイクロソフトのサイトを参考にしました。
ShellSpecialFolderConstants enumeration
CSIDL(Windows SDKをダウンロードして、IncludeフォルダのShlobj.hファイルを見ます)
Windows SDK and emulator archive
' SpecialFoldersModule
Option Explicit
Option Base 1
Option Compare Binary

' Windows フォルダ名を返します。
Public Function WindowsFolder() As String
  Const csWindowsFolder = 0
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  WindowsFolder = FSO.GetSpecialFolder(csWindowsFolder)
  Set FSO = Nothing
End Function
' System フォルダ名を返します。
Public Function SystemFolder() As String
  Const csSystemFolder = 1
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  SystemFolder = FSO.GetSpecialFolder(csSystemFolder)
  Set FSO = Nothing
End Function
' Temporary フォルダ名を返します。
Public Function TemporaryFolder() As String
  Const csSTemporaryFolder = 2
  Dim FSO

  Set FSO = CreateObject("Scripting.FileSystemObject")
  TemporaryFolder = FSO.GetSpecialFolder(csSTemporaryFolder)
  Set FSO = Nothing
End Function
' すべてのユーザーの Desktop フォルダ名を返します。
Public Function AllUsersDesktop() As String
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  AllUsersDesktop = WS.SpecialFolders("AllUsersDesktop")
  Set WS = Nothing
End Function
' すべてのユーザーの StartMenu フォルダ名を返します。
Public Function AllUsersStartMenu() As String
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  AllUsersStartMenu = WS.SpecialFolders("AllUsersStartMenu")
  Set WS = Nothing
End Function
' すべてのユーザーの AllUsersPrograms フォルダ名を返します。
Public Function AllUsersPrograms() As String
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  AllUsersPrograms = WS.SpecialFolders("AllUsersPrograms")
  Set WS = Nothing
End Function
' すべてのユーザーの AllUsersStartup フォルダ名を返します。
Public Function AllUsersStartup() As String
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  AllUsersStartup = WS.SpecialFolders("AllUsersStartup")
  Set WS = Nothing
End Function
' 現在のユーザーのDesktop フォルダ名を返します。
Public Function Desktop() As String
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  Desktop = WS.SpecialFolders("Desktop")
  Set WS = Nothing
End Function
' 現在のユーザーの Favorites フォルダ名を返します。
Public Function Favorites() As String
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  Favorites = WS.SpecialFolders("Favorites")
  Set WS = Nothing
End Function
' Fonts フォルダ名を返します。
Public Function Fonts() As String
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  Fonts = WS.SpecialFolders("Fonts")
  Set WS = Nothing
End Function
' MyDocuments フォルダ名を返します。
Public Function MyDocuments() As String
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  MyDocuments = WS.SpecialFolders("MyDocuments")
  Set WS = Nothing
End Function

' 特殊フォルダのNamespaceの列挙は下記のマイクロソフトのサイトを参考にしました。
' ShellSpecialFolderConstants enumeration
' https://msdn.microsoft.com/en-us/library/windows/desktop/bb774096.aspx
' CSIDL(Windows SDKをダウンロードして、IncludeフォルダのShlobj.hファイルを見ます)
' https://msdn.microsoft.com/en-us/library/windows/desktop/bb762494.aspx
' Windows SDK and emulator archive
' https://developer.microsoft.com/en-us/windows/downloads/sdk-archive

' AllUsersMusic フォルダ名を返します。
Public Function AllUsersMusic() As String
  Dim WS

  Set WS = CreateObject("Shell.Application")
  AllUsersMusic = WS.Namespace(53).Self.Path
  Set WS = Nothing
End Function
' AllUsersPictures フォルダ名を返します。
Public Function AllUsersPictures() As String
  Dim WS

  Set WS = CreateObject("Shell.Application")
  AllUsersPictures = WS.Namespace(54).Self.Path
  Set WS = Nothing
End Function
' AllUsersVideos フォルダ名を返します。
Public Function AllUsersVideos() As String
  Dim WS

  Set WS = CreateObject("Shell.Application")
  AllUsersVideos = WS.Namespace(55).Self.Path
  Set WS = Nothing
End Function
' MyMusic フォルダ名を返します。
Public Function MyMusic() As String
  Dim WS

  Set WS = CreateObject("Shell.Application")
  MyMusic = WS.Namespace(13).Self.Path
  Set WS = Nothing
End Function
' MyVideos フォルダ名を返します。
Public Function MyVideos() As String
  Dim WS

  Set WS = CreateObject("Shell.Application")
  MyVideos = WS.Namespace(14).Self.Path
  Set WS = Nothing
End Function
' History フォルダ名を返します。
Public Function History() As String
  Dim WS

  Set WS = CreateObject("Shell.Application")
  History = WS.Namespace(34).Self.Path
  Set WS = Nothing
End Function
' MyPictures フォルダ名を返します。
Public Function MyPictures() As String
  Dim WS

  Set WS = CreateObject("Shell.Application")
  MyPictures = WS.Namespace(39).Self.Path
  Set WS = Nothing
End Function

' NetHood フォルダ名を返します。
Public Function NetHood() As String
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  NetHood = WS.SpecialFolders("NetHood")
  Set WS = Nothing
End Function
' PrintHood フォルダ名を返します。
Public Function PrintHood() As String
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  PrintHood = WS.SpecialFolders("PrintHood")
  Set WS = Nothing
End Function
' 現在のユーザーの Programs フォルダ名を返します。
Public Function Programs() As String
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  Programs = WS.SpecialFolders("Programs")
  Set WS = Nothing
End Function
' 現在のユーザーの Recent フォルダ名を返します。
Public Function Recent() As String
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  Recent = WS.SpecialFolders("Recent")
  Set WS = Nothing
End Function
' 現在のユーザーの SendTo フォルダ名を返します。
Public Function SendTo() As String
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  SendTo = WS.SpecialFolders("SendTo")
  Set WS = Nothing
End Function
' 現在のユーザーの StartMenu フォルダ名を返します。
Public Function StartMenu() As String
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  StartMenu = WS.SpecialFolders("StartMenu")
  Set WS = Nothing
End Function
' 現在のユーザーの Startup フォルダ名を返します。
Public Function Startup() As String
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  Startup = WS.SpecialFolders("Startup")
  Set WS = Nothing
End Function
' 現在のユーザーの Templates フォルダ名を返します。
Public Function Templates() As String
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  Templates = WS.SpecialFolders("Templates")
  Set WS = Nothing
End Function
' 指定した番号の特殊フォルダ名を返します。
Public Function SpecialFolders(nFolder As Long) As String
' nFolder
'   1 C:\ProgramData\Microsoft\Windows\Start Menu
'   2 C:\ProgramData\Microsoft\Windows\Start Menu\Programs
'   3 C:\ProgramData\Microsoft\Windows\Start Menu\Programs\Startup
'   4 C:\Users\≪ユーザー名≫\Desktop
'   5 C:\Users\≪ユーザー名≫\AppData\Roaming
'   6 C:\Users\≪ユーザー名≫\AppData\Roaming\Microsoft\Windows\Printer Shortcuts
'   7 C:\Users\≪ユーザー名≫\AppData\Roaming\Microsoft\Windows\Templates
'   8 C:\Windows\Fonts
'   9 C:\Users\≪ユーザー名≫\AppData\Roaming\Microsoft\Windows\Network Shortcuts
'  10 C:\Users\≪ユーザー名≫\Desktop
'  11 C:\Users\≪ユーザー名≫\AppData\Roaming\Microsoft\Windows\Start Menu
'  12 C:\Users\≪ユーザー名≫\AppData\Roaming\Microsoft\Windows\SendTo
'  13 C:\Users\≪ユーザー名≫\AppData\Roaming\Microsoft\Windows\Recent
'  14 C:\Users\≪ユーザー名≫\AppData\Roaming\Microsoft\Windows\Start Menu\Programs\Startup
'  15 C:\Users\≪ユーザー名≫\Favorites
'  16 C:\Users\≪ユーザー名≫\Documents
'  17 C:\Users\≪ユーザー名≫\AppData\Roaming\Microsoft\Windows\Start Menu\Programs
' 【注意】≪ユーザー名≫はログオンしたユーザー名です。環境により異なります。
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  SpecialFolders = WS.SpecialFolders(nFolder)
  Set WS = Nothing
End Function

このページの上

OtherModule
' OtherModule
Option Explicit
Option Base 1
Option Compare Binary

' SecondsToWait ポップアップ ウィンドウを閉じるまで待機する秒数を指定します。(省略した場合は10秒です)
Public Function Popup(Prompt As String, Optional Butttons As VbMsgBoxStyle = vbOKOnly, Optional Title As String, Optional SecondsToWait As Long = 10) As VbMsgBoxResult
  Dim WS
  
  Set WS = CreateObject("WScript.Shell")
  Popup = WS.Popup(Prompt, SecondsToWait, Title, Butttons)
  Set WS = Nothing
End Function

' 「Popup」ボタンのクリック処理
Sub PopupMessage()
  Popup Prompt:="メッセージを表示して、5秒後に閉じます。", Butttons:=vbOKOnly, Title:="ポップアップ ウィンドウ", SecondsToWait:=5
End Sub

' VBAのShellとは異なり、拡張子に関連付けたファイルでも実行します。例えば拡張子の .html にブラウザが関連付けられているとブラウザでファイルを実行します。
' Run strCommand, WindowsStyle, WaitOnReturn
Public Function zsExecute(strCommand As String, Optional intWindowStyle As Long = 1, Optional bWaitOnReturn As Long = 0) As Long
' strCommand: 実行するコマンド ラインの文字列
' intWindowStyle 内容
'   0 ウィンドウを非表示。
'   1 ウィンドウをアクティブにして表示します。
'   2 最小化ウィンドウ。
'   3 最大化ウィンドウ。
'
' bWaitOnReturn
'   0 処理を待ちません。
'   0以外の値 終わるまで処理を待ちます。
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  zsExecute = WS.Run(strCommand, intWindowStyle, bWaitOnReturn) ' Run コマンド、ウィンドウのスタイル、処理が終了するまで待つか
  Set WS = Nothing
End Function

Sub Run_Notepad() ' メモ帳を起動
  Dim WS

  Set WS = CreateObject("WScript.Shell")
  zsExecute "Notepad.exe", vbNormalFocus, True
  MsgBox Prompt:="メモ帳を起動しました。", Buttons:=vbInformation, Title:="情報"
  Set WS = Nothing
End Sub

Sub TestShell()
  Dim ret As Long
  
  ret = Shell("Notepad.exe", vbNormalFocus) ' 実行ファイルのみです。拡張子に関連付けたファイルを実行できません。
  If ret = 0 Then
    MsgBox Prompt:=Err.Description, Buttons:=vbCritical, Title:="エラー"
  End If
End Sub

このページの上