ホームページ (URL) を開く 閉じる 益永八尋 VBA からホームページを開いたり 閉じたりします ホームページを開くはシート名 HP_Open で操作し ホームページを閉じるはシート名 "HP_Close" で操作します ホームページを開く方法はいくつかありますがここでは 1 例のみを表示します なお これは Web から入手したサンプルプログラムから使い勝手が良いように修正 追加したものです 使用頻度の高い HP は下表に URL を登録し 表示するものだけを表示させるようにできます 表は最大 20 件まで登録できますが プログラム (VBA) の変更を行えば 登録件数を増やせます プログラムコードは公開していますので この EXCEL をダウンロードすることで修正が可能です なお 実行 のボタンをクリックしないでも URL をクリックすればクリックした URL のみが表示されます

URL を開く Ⅰ. モジュール構成 Ⅱ.Microsoft Excel Objects Sheet1(HP_Open) に記述されているコード注 ) 下記コードはコマンドボタン 1 がクリックされたときに実行されるコードです コマンドボタンは Sheet1(HP_Open) に貼り付けられている Private Sub CommandButton1_Click() ActiveWorkbook.Sheets("HP_Open").Select J = 0 '------------------------------- For I = 1 To 20 MyURL(I) = Cells(I + 20, 3) MyKey(I) = Cells(20 + I, 6)

'---------------------------- If Cells(I + 20, 3) = "" Then Dn = I - 1 Exit For '---------------------- A1 = Left(MyURL(I), 7) A2 = Left(MyURL(I), 8) '-------------------- If A1 <> "http://" And A2 <> "https://" Then MsgBox I & " 番目 " & MyURL(I) & " は URL の書式になっていない " & Chr(13) & " 変更してください " End '-------------------------- Next I '------------------------------- For I = 1 To Dn '-------------------------- If MyKey(I) = " 有 " Then Call Module1.URL_Open1 '--------------------------- Next I

'------------------------------- End End Sub Ⅲ. 標準モジュール Module1 に記述されているコード Public MyURL(20) As String Public MyKey(20) As String Public I As Integer Public Dn As Integer Public J As Integer Sub URL_Open1() On Error GoTo errhandler '---------------------------------------- AA = Shell("EXPLORER.EXE" & Space(1) & MyURL(I), vbminimizedfocus) '--------------------------------------- 'URL を確実に開くには下記 2 行のコードが必要と思われる このコードがない場合には 'URL を表示する時間が短くなり 表示される前に次の URL を開くコードが実行されるこ ' とになる このため 表示されるべき URL が表示されないままになる J = J + 1 MsgBox J & " 番目 " & MyURL(J) '--------------------------------------------------------------------------------------------------- If AA = Null Then

MsgBox " 指定された URL は開けません " & Chr(13) & "URL が正確でない または HP が削除されています " '------------------------- Exit Sub errhandler: errno = Err.Number MsgBox Err.Description Resume Next End Sub errno = Err.Number MsgBox Err.Description Resume Next End Sub

URL を開く Ⅰ. モジュール構成 Ⅱ.Microsoft Excel Objects Sheet2(HP_Close) に記述されているコード注 ) 下記コードはコマンドボタン 1 と 2 がクリックされたときに実行されるコードです コマンドボタンは Sheet2(HP_Close) に貼り付けられている Private Sub CommandButton1_Click() ' 現在開いている HP のリストを作成する Call Module2.URL_List End End Sub Private Sub CommandButton2_Click()

' 現在開いている HP のリストから指定した HP を閉じる Call Module2.URL_Close End End Sub Ⅲ. 標準モジュール Module2 に記述されているコード Sub URL_List() ' 現在開いている URL の List を作成し シート名 HP_Close" に出力する Dim objshell As Object Dim objie As Object Dim J As Integer '---------------------------------------------- On Error GoTo errhandler ' これで エクスプローラーのウインドウを取得する Set objshell = CreateObject("Shell.Application") ' 後ろから消してく.Windows でエクスプローラーとインターネットエクスプローラーに触れる '------------------------------------------------------------------------------------------ Dn = objshell.windows.count ' 現在開いている URL の個数を得る '-------------------------- For I = Dn To 1 Step -1 '

数 Set objie = objshell.windows(i - 1) 'I 番目のウインドウを代入 '-------------------------------------- '.FullName で普通のファイルエクスプローラーと IE( インターネットエクスプローラー ) を区別する MyPath = objie.fullname 'IE( インターネットエクスプローラー ) の Path 名 'AA = Right(UCase(objIE.FullName), 12) 'Ucase: アルファベットの小文字を大文字に変換する関 AA = Right(MyPath, 12) If AA = "IEXPLORE.EXE" Or AA = "iexplore.exe" Then MyURL(Dn - I + 1) = objie.document.url ' 現在開いている URL を取得する '------------------ Set objie = Nothing Next I '---------------------- Set objshell = Nothing '--------------------------------- ' 現在開いている URL の List を作成 Sheets("HP_Close").Select J = 0 '-------------------- For I = 1 To Dn If MyURL(I) <> "" Then J = J + 1

Cells(I + 20, 3) = MyURL(J) Next I '-------------------- Exit Sub '-------------------- errhandler: errno = Err.Number DOK = MsgBox(Err.Description & Chr(13) & " 終了します ", vbyesno) If DOK = vbyes Then End Else Resume Next End Sub Sub URL_Close() ' 現在開いている URL の List から 閉じる URL( ホームページ ) を指定した URL を終了させる Dim objshell As Object Dim objie As Object Dim n As Integer '------------------------------------ ' 現在開いている URL の List を作成

数 Sheets("HP_Close").Select For I = 1 To 20 MyKey(I) = Cells(I + 20, 6) '---------------------------- If Cells(I + 20, 3) = "" Then Dm = I - 1 Exit For Next I '------------------------------------------------------------------------------------------ ' これで エクスプローラーのウインドウを取得する Set objshell = CreateObject("Shell.Application") '------------------------------------------------------------------------------------------- Dn = objshell.windows.count ' 現在開いている URL の個数を得る For I = Dn To 1 Step -1 ' Set objie = objshell.windows(i - 1) 'I 番目のウインドウを代入 '-------------------------------------- '.FullName で普通のファイルエクスプローラーと IE( インターネットエクスプローラー ) を区別する MyPath = objie.fullname 'IE( インターネットエクスプローラー ) の Path 名 'AA = Right(UCase(objIE.FullName), 12) 'Ucase: アルファベットの小文字を大文字に変換する関 AA = Right(MyPath, 12) BB = objie

'-------------------------------------------------------- If AA = "IEXPLORE.EXE" Or AA = "iexplore.exe" Then ' 現在開いている URL を取得する MyURL(Dn - I + 1) = objie.document.url する '----------------------------------------------------- If MyURL(Dn - I + 1) <> "" Then If MyKey(Dn - I + 1) = " 有 " Then objie.quit 'Call Module2.ie_close '----------------------- Sheets("HP_Close").Select ' 閉じた URL をリストから削除する Cells(20 + Dn - I + 1, 3) = "" Cells(20 + Dn - I + 1, 6) = "" '----------------------- Next I '-------------------- Set objshell = Nothing ' 最後に開いた URL から若い順番に URL を取得 ' '.QUIT で該当 URL を閉じる

End Sub 2012/10/24