'========================================================================================= ' 187 アシスタントのインストール状況を調べて表示する '----------------------------------------------------------------------------------------- '【ヒント】 ' このマクロは、おためし機能の動作用のコードです。 ' タイトル機能に関係するコードは、UserForm1のコード画面にあります。 '========================================================================================= ' ◆標準モジュールのコード◆ '----------------------------------------------------------------------------------------- Option Explicit '【ご注意】★★★のない行はタイトル機能とは無関係です Dim エクセル As String Dim バージョン As String Public タイトル As String Public スタイル As Long Public メッセージ As String Public 応答 As Variant '----------------------------------------------------------------------------------------- Sub おためしマクロ() おためしメッセージを表示する If エクセル = "9.0" Then 'Excel2000なら UserForm1.Show Else Excel2000以外のことわり End If End Sub '----------------------------------------------------------------------------------------- Private Sub おためしメッセージを表示する() Worksheets("Title").Select Range("D8:I14").ClearContents Range("P17").Select 'カーソルを定位置へ移動する Excelのバージョンを取り出す OSの名前を表示する タイトル = "500連発 第2弾 サンプルマクロ" スタイル = 64 'vbInformation メッセージ = "アシスタントのインストール状況を調べて表示します" 応答 = MsgBox(メッセージ, スタイル, タイトル) End Sub '----------------------------------------------------------------------------------------- Private Sub Excelのバージョンを取り出す() エクセル = Left(Worksheets("Title").Range("L1").Value, 3) 'バージョンを取得する End Sub '----------------------------------------------------------------------------------------- Sub OSの名前を表示する() バージョン = Application.OperatingSystem 'OSのバージョン情報を取り出す If バージョン = "Windows (32-bit) NT 5.00" Then '●●なら Cells(1, 10) = "Windows2000" ElseIf バージョン = "Windows (32-bit) 4.10" Then Cells(1, 10) = "Windows98" ElseIf バージョン = "Windows (32-bit) 4.00" Then Cells(1, 10) = "Windows95" Else 'それ以外 Cells(1, 10) = "不明" End If End Sub '----------------------------------------------------------------------------------------- Sub Excel2000以外のことわり() メッセージ = "ごめんなさい！" & Chr(13) & Chr(13) & _ "このサンプルは、Excel 2000用です" スタイル = 16 'vbCritical 応答 = MsgBox(メッセージ, スタイル, タイトル) End Sub '----------------------------------------------------------------------------------------- Sub Auto_Close() Application.DisplayAlerts = False '閉じる際に確認メッセージを出さない ActiveWorkbook.Close '現在開いているブックを閉じる End Sub '----------------------------------------------------------------------------------------- '========================================================================================= ' ◆UserForm1のコード◆ '----------------------------------------------------------------------------------------- Option Explicit '【ご注意】★★★のない行はタイトル機能とは無関係です Dim サーチ As Object '★★★ Dim ファイル数 As Integer '★★★ Dim ドライブ As String '★★★ Dim パス As String '★★★ Dim 拡張子 As String '★★★ '----------------------------------------------------------------------------------------- Private Sub アシスタントのインストール状況を調べて表示する() '★★★ パス = TextBox1.Text 'テキストボックス1からパスを取得する 拡張子 = TextBox2.Text 'テキストボックス2から拡張子を取得する On Error GoTo エラー処理 '次の2行のステートメントでエラーになった場合のジャンプ先を設定する ChDrive ドライブ '現在のドライブを変更する ChDir パス '現在のパスを変更する On Error GoTo 0 Set サーチ = Application.FileSearch 'ファイル検索 With サーチ .LookIn = パス .Filename = 拡張子 If .Execute > 0 Then メッセージ = .FoundFiles.Count & " 個のファイルが見つかりました。" 応答 = MsgBox(メッセージ, スタイル, タイトル) For ファイル数 = 1 To .FoundFiles.Count If ファイル数 <= 7 Then Cells(ファイル数 + 7, 4) = ファイル数 Cells(ファイル数 + 7, 5) = .FoundFiles(ファイル数) Else メッセージ = "" & ファイル数 & " " & .FoundFiles(ファイル数) 応答 = MsgBox(メッセージ, スタイル, タイトル) End If Next Else メッセージ = "選択されたパス（" & パス & "）には、" & Chr(13) & Chr(13) & _ "「 " & 拡張子 & " 」のファイルは見つかりません" 応答 = MsgBox(メッセージ, スタイル, タイトル) End If End With Exit Sub ' エラー処理: メッセージ = "パス（" & パス & "）が見つからないので、調査できません" スタイル = 16 'vbCritical 応答 = MsgBox(メッセージ, スタイル, タイトル) On Error GoTo 0 End Sub '----------------------------------------------------------------------------------------- Private Sub CommandButton1_Click() UserForm1.Hide アシスタントのインストール状況を調べて表示する Unload Me End Sub '----------------------------------------------------------------------------------------- Private Sub UserForm_Initialize() ドライブ = "C" パス = "\" 拡張子 = "*.acg" テキストボックスに文字列を設定する End Sub '----------------------------------------------------------------------------------------- Private Sub CheckBox3_Click() ドライブ = "C" テキストボックスに文字列を設定する End Sub '----------------------------------------------------------------------------------------- Private Sub CheckBox4_Click() ドライブ = "D" テキストボックスに文字列を設定する End Sub '----------------------------------------------------------------------------------------- Private Sub CheckBox5_Click() ドライブ = "E" テキストボックスに文字列を設定する End Sub '----------------------------------------------------------------------------------------- Private Sub CheckBox6_Click() ドライブ = "A" テキストボックスに文字列を設定する End Sub '----------------------------------------------------------------------------------------- Private Sub CheckBox7_Click() ドライブ = "B" テキストボックスに文字列を設定する End Sub '----------------------------------------------------------------------------------------- Private Sub CheckBox1_Click() 'シングルインストール パス = "\Program Files\Microsoft Office\Office" 拡張子 = "*.acg" テキストボックスに文字列を設定する End Sub '----------------------------------------------------------------------------------------- Private Sub CheckBox2_Click() 'ダブルインストール パス = "\Program Files\MS Office2000\Office" 拡張子 = "*.acs" テキストボックスに文字列を設定する End Sub '----------------------------------------------------------------------------------------- Private Sub テキストボックスに文字列を設定する() TextBox1.Text = ドライブ & ":" & パス TextBox2.Text = 拡張子 End Sub '----------------------------------------------------------------------------------------- Private Sub UserForm_Deactivate() Unload Me End Sub '=========================================================================================