いかちソフトウェア

「しばらくお待ちください」を表示するインストーラー

トップ > テクニック

VBScriptで「しばらくお待ちください」画面を表示したインストーラーをVBScriptで作成する

VBScriptで「しばらくお待ちください」画面を表示したインストーラーを作成しました。
ご活用いただければ幸いです。

このインストーラーの概要は、次のとおりです。

  • 管理者権限がなければ、インストールを実行しない
  • .NET Framework、サードパーティ製のActiveReports/InputManを併せてインストールする。
  • アプリのショートカットをスタートアップに登録
インストーラーを実行すると、まず実行したユーザーに管理者権限があるかどうかをチェックします。
管理者権限がなければ、.NET FrameworkやActiveReportsなど、実行環境の構築に必要な各種インストーラーを実行できないためです。
実行環境の構築に必要なソフトがすでにインストールされているかどうかをチェックし、インストールされていなければそれぞれのインストーラーを実行します。
実行環境の構築に必要なインストーラーは、このスクリプトファイルと同一ディレクトリに「app」フォルダを作成し、その中に配置しておきます。
次に、指定したフォルダに配布モジュールをコピーし、その中の実行ファイルの1つのショートカットをスタートアップに作成します。
(Windowsの起動と同時にアプリを実行させるのが目的です)
配布モジュールのコピーだけであればすぐに終わる場合でも、.NET FrameworkやActiveReports、InputManがインストールされているかどうかの判断がそれなりに時間がかかるため、進捗ダイアログを作成した方がよいと判断しました。
VBScriptの関数群ではフォームを作成することができないので、進捗ダイアログにはInternet Explorerを利用しています。
Internet Explorerで進捗ダイアログを表示する方法については、Microsoftの「Hey, Scripting Guy!」を参考にしました。

Hey, Scripting Guy! : スクリプトの実行中に進行状況バー (またはそれに似たもの) を表示する方法はありますか

さて、作成したインストーラーの全ソースコードは、次のとおりです。

'フォントをセットアップするためのスクリプトです。
'このスクリプトと同一ディレクトリに「FONT」フォルダを作成し、
'そのフォルダ内にインストールするフォントファイルを格納します。
'********************************************************************************
' 概要   :.NET Framework、ActiveReports、InputManを利用したアプリのインストーラー
' 作成者  :ikachiSoftware
' 作成日  :2016.04.28
' 最終更新日:2016.04.28
'********************************************************************************
Option Explicit

'このスクリプトのプロジェクト名です。
Const PROJECT_NAME = "hogeシステム セットアップ"

'------------------------------
' 管理者権限チェック
'------------------------------
If (IsAdministrators() = False) Then
  '管理者権限を持たないユーザーの場合、インストールを中断します
  Call MsgBox("管理者権限を持つユーザーで実行して下さい。", vbExclamation + vbOkOnly, PROJECT_NAME)
  WScript.Quit
End If

'------------------------------
' 管理者として実行
'------------------------------
If (WScript.Arguments.Count = 0) Then
  CreateObject("Shell.Application").ShellExecute "wscript.exe", """" & WScript.ScriptFullName & """ uac", "", "runas"
  WScript.Quit
End If

'------------------------------
' インストールプログラム
'------------------------------
'1. Microsoft .NET Framework 4.5
'2. ActiveReports .Net 6(6.2.2659.1)
'3. InputMan for Win 6(6.0.2010.1029)
Dim INSTALL_APP
INSTALL_APP = Array("Microsoft .NET Framework 4", "PowerTools InputMan", "PowerTools ActiveReports")

'------------------------------
' メイン処理
'------------------------------
'セットアップを開始します
Call StartSetup

'================================================================================
' 概要 :セットアップを開始します
' 引数 :なし
' 戻り値:なし
'================================================================================
Sub StartSetup()

  '実行環境に必要なアプリをインストールします。
  Dim i
  For i = 0 To UBound(INSTALL_APP)
    Dim instApp
    instApp = INSTALL_APP(i)

    Dim f
    Call OpenProgress(f, instApp)

    If (IsInstalled(instApp) = False) Then
      Call CloseProgress(f)
      Call InstallApp(instApp)
    Else
      Call CloseProgress(f)
    End If
  Next

  '「hoge」フォルダをCドライブにコピーします。
  If (InstallHoge() = False) Then
    Call MsgBox("Hogeモジュールのコピーに失敗しました。", vbExclamation + vbOkOnly, PROJECT_NAME)
    Exit Sub
  End If

  '"C:\Hoge\HogeSystem.exe"のショートカットをスタートアップに登録します。
  Call CreateShortcutToStartup

  '完了メッセージを表示します
  Call MsgBox("Hoge System のセットアップが完了しました。", vbInformation + vbOkOnly, PROJECT_NAME)

'  '親フォルダを削除します
'  Call RemoveParentFolder
End Sub

'================================================================================
' 概要 :指定したアプリがインストールされているかどうかをチェックします。
' 引数 :[instApp]...インストールチェックを行うアプリ名
' 戻り値:指定したアプリがインストールされていればTrue、インストールされていなければFalse
'================================================================================
Function IsInstalled(ByVal instApp)
  Dim wql
  wql = "SELECT Caption FROM Win32_Product WHERE Caption LIKE '%" + instApp + "%'"

  Dim clSet
  Set clSet = WScript.CreateObject("WbemScripting.SWbemLocator").ConnectServer.ExecQuery(wql)

  If (0 < clSet.Count) Then
    IsInstalled = True
  Else
    IsInstalled = False
  End If
End Function

'================================================================================
' 概要 :指定したアプリをインストールします。
' 引数 :[instApp]...インストールするアプリ名
' 戻り値:なし
'================================================================================
Sub InstallApp(ByVal instApp)
  Select Case instApp
    'Microsoft .NET Framework 4.5
    Case INSTALL_APP(0)
      Call ExecuteBackground(MyDir & "app\net.exe")
    'PowerTools InputMan for Windows Forms 6.0J Runtime SP2
    Case INSTALL_APP(1)
      Call ExecuteBackground(MyDir & "app\ipman.msi")
    'PowerTools ActiveReports for .NET 6.0J Runtime SP2
    Case INSTALL_APP(2)
      Call ExecuteBackground(MyDir & "app\actrep.msi")
  End Select
End Sub

'================================================================================
' 概要 :バックグラウンドで指定されたファイルを実行します
' 引数 :なし
' 戻り値:なし
'================================================================================
Sub ExecuteBackground(ByVal exepath)
  Const vbHide = 0  'ウィンドウを非表示

  'WScipt.Shellを参照します
  Dim wshell
  Set wshell = CreateObject("WScript.Shell")

  On Error Resume Next

  'ファイルを実行します
  wshell.Run """" & exepath & """", vbHide, True
  If (Err.Number <> 0) Then
    Dim msg
    msg = ""
    msg = msg & CStr(Err.Number) & ":" & Err.Description & vbCrLf
    msg = msg & vbCrLf
    msg = msg & "参照ファイルパス:" & exepath
    Call MsgBox(msg, vbCritical + vbOkOnly, PROJECT_NAME)
    Exit SUb
  End If

  On Error GoTo 0
End Sub

'================================================================================
' 概要 :Hogeをインストールします。
' 引数 :なし
' 戻り値:正常にインストールできればTrue、インストールできなければFalse
'================================================================================
Function InstallHoge()
  Dim source
  source = MyDir & "Hoge"
  Dim destination
  destination = "C:\Hoge"

  On Error Resume Next

  Call FolderCopy(source, destination)
  If (Err.Number <> 0) Then
    Call MsgBox(CStr(Err.Number) & ":" & Err.Description, vbOkOnly + vbCritical, PROJECT_NAME)
    InstallHoge = False
  End If

  On Error GoTo 0

  InstallHoge = True
End Function

'================================================================================
' 概要 :スタートアップにHogeのスタートアップのショートカットを作成します。
' 引数 :なし
' 戻り値:なし
'================================================================================
Sub CreateShortcutToStartup()
  'スタートアップフォルダのパスを取得します。
  Dim stFolder
  stFolder = WScript.CreateObject("WScript.Shell").SpecialFolders("Startup")

  'ショートカットを作成します。
  Dim sc
  Set sc = CreateObject("WScript.Shell").CreateShortcut(stFolder & "\HogeSystem.lnk")
  sc.TargetPath = "C:\Hoge\HogeSystem.exe"
  sc.save
End Sub

'================================================================================
' 概要 :このスクリプトが存在するフォルダを削除します
' 引数 :なし
' 戻り値:なし
'================================================================================
Function RemoveParentFolder()
  Dim f
  Set f = CreateObject("Scripting.FileSystemObject").GetFolder(MyDir)

  On Error Resume Next

  f.Delete
  If (Err.Number <> 0) Then
    Err.Clear
  End If

  On Error GoTo 0
End Function

'================================================================================
' 概要 :このスクリプトが存在するフォルダパスを返します
' 引数 :なし
' 戻り値:このスクリプトが存在するフォルダパス
'================================================================================
Function MyDir()
  MyDir = Replace(WScript.ScriptFullName, WScript.ScriptName, "")
End Function

'================================================================================
' 概要 :フォルダをコピーします。
' 引数 :[source]...コピー元フォルダ
'     [destination]...コピー先フォルダ
' 戻り値:このスクリプトが存在するフォルダパス
'================================================================================
Function FolderCopy(ByVal source, ByVal destination)
  Call CreateObject("Scripting.FileSystemObject").CopyFolder(source, destination)
End Function

'================================================================================
' 概要 :ログインユーザーがAdministratorsに含まれるかどうかをチェックします
' 引数 :なし
' 戻り値:Administratorsに含まれればTrue、含まれなければFalse
'================================================================================
Function IsAdministrators()

  '戻り値を初期化します
  IsAdministrators = False

  'ネットワークオブジェクトを参照します
  Dim nw
  Set nw = CreateObject("Wscript.Network")

  'コンピューター名を取得します
  Dim compname
  compname = nw.ComputerName

  'ログインユーザー名を取得します
  Dim usrname
  usrname = nw.UserName

  'Administratorsグループの一覧を取得します
  Dim grp
  Set grp = GetObject("WinNT://" & compname & "/Administrators")

  Dim bExists
  bExists = False

  'Administratorsグループに含まれるユーザーとログインユーザーを比較します
  Dim usr
  For Each usr in grp.Members
    'ログインユーザー名と一致するユーザー名がAdministratorsグループに存在する場合
    If (usr.Name = usrname) Then
      bExists = True
      Exit For
    End If
  Next

  'ログインユーザーがAdministratorsグループに含まれていた場合、戻り値にTrueを返します
  If (bExists) Then
    IsAdministrators = True
  Else
  'ログインユーザーがAdministratorsグループに含まれていなかった場合、戻り値にFalseを返します
    IsAdministrators = False
  End If

End Function

'================================================================================
' 概要 :進捗ページを表示します。
' 引数 :[f]...進捗ページのインスタンス
'     [msg]...進捗ページに表示するメッセージ
' 戻り値:なし
'================================================================================
Sub OpenProgress(ByRef f, ByVal msg)
  Set f = CreateObject("InternetExplorer.Application")

  f.Navigate "about:blank"
  f.ToolBar = False
  f.StatusBar = False

  Dim h
  Dim v

  Dim colSet
  Set colSet = GetObject("Winmgmts:\\.\root\cimv2").ExecQuery("Select * From Win32_DesktopMonitor")
  Dim col
  For Each col in colSet
    h = col.ScreenWidth
    v = col.ScreenHeight
  Next

  f.Left = (h - 400) / 2
  f.Top = (v - 200) / 2

  f.Width = 400
  f.Height = 200
  f.Visible = 1

  f.Document.Title = PROJECT_NAME

  Dim html
  html = ""
  html = html & ""
  html = html & ""
  html = html & "Hoge セットアップ"
  html = html & ""
  html = html & ""
  html = html & ""
  html = html & "

Hoge System のセットアップ中です...

" html = html & "

" & msg & "

" html = html & "□□□□□" html = html & "" html = html & "" html = html & "" f.Document.Body.InnerHTML = html End Sub '================================================================================ ' 概要 :ログインユーザーがAdministratorsに含まれるかどうかをチェックします ' 引数 :なし ' 戻り値:Administratorsに含まれればTrue、含まれなければFalse '================================================================================ Sub CloseProgress(ByRef f) On Error Resume Next f.Quit Set f = Nothing If (Err.Number <> 0) Then Err.Clear End If On Error GoTo 0 End Sub