Sub MyXlNhk()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem NHKサイト[ニュース]ページ取り込み処理（HttpRequest使用）
  Rem 作譜：Hitrock Camellia Shinopy
  Rem 言語：Excel VBA
  Rem 機能...
  Rem   NHKサイトの[ニュース]ページを読み込みし、
  Rem   Excelシートに書き込みする。
  Rem 注記...
  Rem   1. MyXlNhkを起動して使用｡
  Rem   2. サイトのページ内容を取り損ねることがあるため、
  Rem      ページを読み込む時に、DoEvents関数で処理を一時停止させる。
  Rem      （これまでの試行により、前のページに戻る時は、不要と思われる。）
  Rem   3. 文字列変数「myIEblank」の値指定は、IEのバージョンによって変更要！
  Rem      「about:blank」と「about:」の対処が、IEのバージョンによって異なるので注意。
  Rem       Cells(r, "B").Value = Replace(myLink.href, "about:blank", myURL, 1, 1) '  IE6以前? MSN版IE7?
  Rem       Cells(r, "B").Value = Replace(myLink.href, "about:", myURL, 1, 1) ' IE7?
  Rem   4. なぜか、IEの「Visible = False」が機能しないので、
  Rem      ExcelのWindowStateの操作で対処。
  Rem 履歴...
  Rem   第1版：2006/04/25：作成。
  Rem   第2版：2006/07/20：特設情報メニューに対応。
  Rem   第3版：2006/09/20：[もっと詳しく]の取り込みを追加。
  Rem   第4版：2006/11/07：IE7に対応：「about:blank」を「about:」に変更した箇所あり。
  Rem   第5版：2007/01/25：Excel2007に対応：バルーン表示を廃止、ポップアップメニューに変更。
  Rem   第6版：2007/05/06：「myIEblank」の値指定を修正。WindowState操作を追加。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 参照設定する場合...
  Rem   Microsoft Internet Controls
  Rem   Microsoft HTML Object Library
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myCmmdBar As CommandBar
  Dim myCtrlBttn As CommandBarControl
  Dim myCtrlBttnDeTail As CommandBarControl
  Dim myCtrlBttnOk As CommandBarControl
  Dim myCtrlBttnCancel As CommandBarControl
  Dim x As Long
  Dim y As Long
  Dim myFaceId As Long
  Dim myMsg As String
  '
  Dim myHTTP As Variant ' IXMLHTTPRequest
  Dim myIE As Variant ' InternetExplorer
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim myLink As Variant ' MSHTML.HTMLAnchorElement
  '
  Dim myTags As Variant ' DispHTMLElementCollection
  Dim myTag As Variant ' HTMLHeaderElement
  '
  Dim mySubTags As Variant ' DispHTMLElementCollection
  Dim mySubTag As Variant ' HTMLHeaderElement
  '
  Dim c As Long
  Dim i As Long
  Dim r As Long
  Dim rr As Variant
  Dim myCount As Long
  Dim myString As String
  Dim myString1 As String
  Dim myString2 As String
  '
  Dim myURL As String
  Dim myURLweb As String
  Dim myPage As String
  Dim myHref As String
  Dim myIEblank As String
  Dim myArrPage As Variant
  Dim myArrHref As Variant
  Dim myStatusBar As String
  '
  Dim myAns  As Long
  Dim myCbox(1) As Boolean
  Dim myinnerText As String
  Dim myText As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  On Error Resume Next
  CommandBars("MyXlNhk").Delete
  On Error GoTo 0
  '
  Set myCmmdBar = CommandBars.Add(Name:="MyXlNhk", Position:=msoBarPopup, Temporary:=True)
  Set myCtrlBttn = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
  Set myCtrlBttnDeTail = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=2, Temporary:=True)
  Set myCtrlBttnOk = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=3, Temporary:=True)
  Set myCtrlBttnCancel = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=4, Temporary:=True)
  '
  myMsg = "MyXlNhk" & vbCrLf & vbCrLf
  myMsg = myMsg & "NHKサイト" & vbCrLf
  myMsg = myMsg & "[ニュース]ページ" & vbCrLf
  myMsg = myMsg & "取り込み処理" & vbCrLf & vbCrLf
  '
  With myCtrlBttn
    .DescriptionText = "NHKサイト[ニュース]ページ取り込み処理ポップアップメニュー"
    .Style = msoButtonIconAndWrapCaption
    .Caption = myMsg & "処理を実行しますか？"
    .TooltipText = "処理を実行しますか？"
    .FaceId = 1089
    myFaceId = .FaceId
  End With
  '
  With myCtrlBttnDeTail
    .DescriptionText = "NHKサイト[ニュース]ページ取り込み処理：[もっと詳しく]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "もっと詳しく"
    .TooltipText = "[もっと詳しく]は取り込まない。"
    .FaceId = 6963
    .OnAction = "MyXlNhkBttnMyDetail"
  End With
  '
  With myCtrlBttnOk
    .DescriptionText = "NHKサイト[ニュース]ページ取り込み処理：[OK]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "OK"
    .TooltipText = "処理をを実行します。"
    .FaceId = 459
    .OnAction = "MyXlNhkBttnMyOk"
  End With
  '
  With myCtrlBttnCancel
    .DescriptionText = "NHKサイト[ニュース]ページ取り込み処理：[キャンセル]ボタン"
    .Style = msoButtonIconAndCaption
    .Caption = "キャンセル" & "　　　　　　　　　　　　"
    .TooltipText = "処理を中止します。"
    .FaceId = 330
    .OnAction = "MyXlNhkBttnMyCancel"
  End With
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  x = ActiveWindow.PointsToScreenPixelsX(0)
  y = ActiveWindow.PointsToScreenPixelsY(0)
  Beep
  Do
    On Error Resume Next
    myCmmdBar.ShowPopup x, y
    On Error GoTo 0
    DoEvents
    If myCmmdBar.Controls(1).FaceId <> myFaceId Then Exit Do
  Loop
  '
  Select Case myCmmdBar.Controls(1).FaceId
    Case 459
      myAns = vbOK
    Case 330
      myAns = vbCancel
  End Select
  '
  If myCmmdBar.Controls(2).FaceId = 220 Then
    myCbox(0) = True
  Else
    myCbox(0) = False
  End If
  '
  On Error Resume Next
  myCmmdBar.Delete
  On Error GoTo 0
  '
  If myAns = vbCancel Then Exit Sub
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem NHKサイトの[ニュース]ページ
  myURL = "http://k.nhk.jp/knews/"
  myURLweb = "http://www.nhk.or.jp/"
  myIEblank = "about:blank" ' IEのバージョンによって変更要！
  ' myIEblank = "about:" ' IEのバージョンによって変更要！
  '
  Sheets(1).Activate
  Application.CommandBars("Task Pane").Visible = False
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myHTTP = CreateObject("MSXML2.XMLHTTP") ' ("Microsoft.XMLHTTP")
  Set myIE = CreateObject("InternetExplorer.Application")
  '
  With myIE
    .Navigate "about:blank"
    .Visible = False ' True
    Do While .Busy
      DoEvents
    Loop
    myStatusBar = "□NHKニュース 読み込み開始"
    Application.StatusBar = "MyXlNhk: " & myStatusBar
    DoEvents
    Set myDoc = .Document
  End With
  Application.WindowState = xlMinimized
  Application.WindowState = xlNormal
  '
  Call myHTTP.Open("GET", myURL, False)
  Call myHTTP.Send
  If myHTTP.readyState <> 4 Then ' 4:READYSTATE_COMPLETE
    myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
    myStatusBar = myStatusBar & "myHTTP.readyState: " & myHTTP.readyState & vbCr
    myStatusBar = myStatusBar & "URL: " & myURL
    MsgBox myStatusBar, vbOKOnly, "MyXlNhk"
    Exit Sub
  End If
  If myHTTP.Status <> 200 Then
    myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
    myStatusBar = myStatusBar & "myHTTP.Status: " & myHTTP.Status & vbCr
    myStatusBar = myStatusBar & "URL: " & myURL
    MsgBox myStatusBar, vbOKOnly, "MyXlNhk"
    Exit Sub
  End If
  '
  myText = StrConv(myHTTP.responseBody, vbUnicode)
  myString = "<a href=" & Chr(34) & "../"
  myText = Replace(myText, myString, "<a Zzzhref=" & Chr(34) & "../")
  myDoc.write myText
  '
  myinnerText = myDoc.body.innerText
  myinnerText = Left(myinnerText, InStr(myinnerText, "更新") + 2)
  myText = Mid(myinnerText, InStr(myinnerText, vbCrLf & vbCrLf) + 2)
  myText = Format(CDate(Replace(myText, "更新", "")), "yyyy年m月d日 hh時nn分 更新")
  '
  Columns("A:A").ColumnWidth = 30#
  Columns("B:B").ColumnWidth = 80#
  Columns("C:C").ColumnWidth = 80#
  ActiveWindow.Zoom = 75
  '
  Rows("1").RowHeight = 50#
  Cells(1, "A").Value = myDoc.Title
  Cells(1, "B").Value = myText
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem トップページ処理
  r = 1
  myHref = myURL
  myPage = "■トップ"
  ActiveSheet.Name = myPage
  '
  Application.StatusBar = "MyXlNhk: " & myStatusBar
  '
  Application.ScreenUpdating = True
  '
  c = 0
  For Each myLink In myDoc.Links
    c = c + 1
    myStatusBar = "□NHKニュース 読み込み開始："
    myStatusBar = myStatusBar & ActiveSheet.Name & c & "/" & myDoc.Links.Length
    Application.StatusBar = "MyXlNhk: " & myStatusBar
    Select Case Left(myLink.innerText, 1)
      Case "■"
        myPage = myPage & "," & myLink.innerText
        myHref = myHref & "," & Replace(myLink.href, myIEblank, myURL, 1, 1)
      Case "●"
        r = r + 1
        Cells(r, "A").Value = myLink.innerText
        Cells(r, "B").Value = Replace(myLink.href, myIEblank, myURL, 1, 1)
        myString = Replace(myLink.href, myIEblank, myURLweb, 1, 1)
        myString1 = Left(myString, InStrRev(myString, "/t") - 1)
        myString2 = Replace(myString, "/t", "/d", InStrRev(myString, "/t"), 1)
        Cells(r, "C").Value = myString1 & myString2
        Cells(r, "A").Select
        Cells(r, "A").Hyperlinks.Add Anchor:=Selection, Address:=Cells(r, "C").Value, _
                                                        TextToDisplay:=Cells(r, "A").Text
        If myCbox(0) = False Then
          Cells(r, "C").Value = ""
        End If
      Case Else
        Rem 特設情報メニューと判断する。
        r = r + 1
        Cells(r, "A").Select
        ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=myLink.href, _
                                                      TextToDisplay:=myLink.innerText
        Cells(r, "B").Value = Replace(myLink.href, myIEblank, myURL, 1, 1)
    End Select
    DoEvents
  Next ' myDoc.links
  '
  myArrPage = Split(myPage, ",")
  myArrHref = Split(myHref, ",")
  '
  If Worksheets.Count < UBound(myArrPage) + 1 Then
    myCount = UBound(myArrPage) + 1 - Worksheets.Count
    For i = 1 To myCount
      Worksheets.Add After:=Sheets(Worksheets.Count), Count:=1
    Next ' i
  End If
  '
  ReDim rr(UBound(myArrPage) + 1)
  For i = 0 To UBound(myArrPage) + 1
    rr(i) = 0
  Next ' i
  rr(1) = r
  rr(0) = r
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem 分野別処理
  For i = 1 To UBound(myArrPage)
    Sheets(i + 1).Activate
    ActiveSheet.Name = myArrPage(i)
    Columns("A:A").ColumnWidth = 30#
    Columns("B:B").ColumnWidth = 80#
    Columns("C:C").ColumnWidth = 80#
    ActiveWindow.Zoom = 75
    '
    With myIE
      .Navigate "about:blank"
      .Visible = False ' True
      Do While .Busy
        DoEvents
      Loop
      myStatusBar = "□NHKニュース 読み込み開始："
      myStatusBar = myStatusBar & myArrPage(i) & i & "/" & UBound(myArrPage)
      Application.StatusBar = "MyXlNhk: " & myStatusBar
      DoEvents
      Set myDoc = .Document
    End With
    '
    myURL = myArrHref(i)
    Call myHTTP.Open("GET", myArrHref(i), False)
    Call myHTTP.Send
    If myHTTP.readyState <> 4 Then ' 4:READYSTATE_COMPLETE
      myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
      myStatusBar = myStatusBar & "myHTTP.readyState: " & myHTTP.readyState & vbCr
      myStatusBar = myStatusBar & "URL: " & myArrHref(i)
      MsgBox myStatusBar, vbOKOnly, "MyXlNhk"
      Exit Sub
    End If
    If myHTTP.Status <> 200 Then
      myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
      myStatusBar = myStatusBar & "myHTTP.Status: " & myHTTP.Status & vbCr
      myStatusBar = myStatusBar & "URL: " & myArrHref(i)
      MsgBox myStatusBar, vbOKOnly, "MyXlNhk"
      Exit Sub
    End If
    '
    myText = StrConv(myHTTP.responseBody, vbUnicode)
    myString = "<a href=" & Chr(34) & "../"
    myText = Replace(myText, myString, "<a Zzzhref=" & Chr(34) & "../")
    myDoc.write myText
    '
    r = 1
    c = 0
    myURL = Left(myURL, InStrRev(myURL, "genre") - 1)
    For Each myLink In myDoc.Links
      c = c + 1
      myStatusBar = "□NHKニュース 読み込み開始："
      myStatusBar = myStatusBar & myArrPage(i) & c & "/" & myDoc.Links.Length
      Application.StatusBar = "MyXlNhk: " & myStatusBar
      Select Case Left(myLink.innerText, 1)
        Case "■"
          Rem
        Case "●"
          r = r + 1
          Cells(r, "A").Value = myLink.innerText
          Cells(r, "B").Value = Replace(myLink.href, myIEblank, myURL, 1, 1)
          myString = Mid(myURL, InStr(myURL, "/news/") + 1)
          Cells(r, "C").Value = myURLweb & myString & Replace(myLink.href, myIEblank & "k", "d")
          Cells(r, "A").Select
          Cells(r, "A").Hyperlinks.Add Anchor:=Selection, Address:=Cells(r, "C").Value, _
                                                          TextToDisplay:=Cells(r, "A").Text
          If myCbox(0) = False Then
            Cells(r, "C").Value = ""
          End If
      End Select
      DoEvents
    Next ' myDoc.links
    Cells(1, "A").Select
    rr(i + 1) = r
    rr(0) = rr(0) + r
    DoEvents
  Next ' i
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Sheets(1).Activate
  ActiveSheet.Range("A1").Select
  c = 0
  If myCbox(0) = True Then
    rr(0) = rr(0) * 2
  End If
  '
  Application.ScreenUpdating = False ' True
  For i = 0 To UBound(myArrPage)
    myStatusBar = "●読み込み中：" & ActiveSheet.Name & " " & i + 1 & "/" & UBound(myArrPage)
    Application.StatusBar = "MyXlNhk: " & myStatusBar
    Sheets(i + 1).Activate
    Call MyXlNhkPage(i, c, rr, myHTTP, myIE)
  Next ' i
  '
  If myCbox(0) = True Then
    For i = 0 To UBound(myArrPage)
      myStatusBar = "●読み込み中：" & ActiveSheet.Name & " " & i + 1 & "/" & UBound(myArrPage)
      Application.StatusBar = "MyXlNhk: " & myStatusBar
      Sheets(i + 1).Activate
      Call MyXlNhkDetl(i, c, rr, myHTTP, myIE)
    Next ' i
  End If
  Application.ScreenUpdating = True
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyXlNhkSubExit:
  Rem myIE.Visible = True
  myIE.Quit
  Application.ScreenUpdating = True
  Sheets(1).Activate
  ActiveSheet.Range("B1").Select
  '
  myStatusBar = "処理が終了しました。"
  Application.StatusBar = "MyXlNhk: " & myStatusBar & Now()
  Application.Speech.Speak myStatusBar, False
  Beep
  '
  Set myHTTP = Nothing
  Set myIE = Nothing
  Set myDoc = Nothing
End Sub ' MyXlNhk *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlNhkPage(i As Long, c As Long, rr As Variant, myHTTP As Variant, myIE As Variant)
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim r As Long
  Dim myURL As String
  Dim myinnerText As String
  Dim myStatusBar As String
  Dim myLead As String
  Dim myText As String
  Dim myDate As String
  '
  c = c + 1
  For r = 2 To rr(i + 1)
    c = c + 1
    If Len(Cells(r, "B").Value) <> 0 Then
      With myIE
        .Navigate "about:blank"
        .Visible = False ' True
        Do While .Busy
          DoEvents
        Loop
        myStatusBar = "●読み込み中：" & c * 100 \ rr(0) & "%　"
        myStatusBar = myStatusBar & ActiveSheet.Name & " "
        myStatusBar = myStatusBar & r & "/" & rr(i + 1) & "行　"
        myStatusBar = myStatusBar & i + 1 & "/" & UBound(rr) & "頁"
        Application.StatusBar = "MyXlNhkPage: " & myStatusBar
        DoEvents
        Set myDoc = .Document
      End With
      '
      myURL = Cells(r, "B").Value
      Call myHTTP.Open("GET", myURL, False)
      myHTTP.Send
      If myHTTP.readyState <> 4 Then ' 4:READYSTATE_COMPLETE
        myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
        myStatusBar = myStatusBar & "myHTTP.readyState: " & myHTTP.readyState & vbCr
        myStatusBar = myStatusBar & "URL: " & myURL
        MsgBox myStatusBar, vbOKOnly, "MyXlNhkPage"
        Exit Sub
      End If
      If myHTTP.Status <> 200 Then
        myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
        myStatusBar = myStatusBar & "myHTTP.Status: " & myHTTP.Status & vbCr
        myStatusBar = myStatusBar & "URL: " & myURL
        MsgBox myStatusBar, vbOKOnly, "MyXlNhkPage"
        Exit Sub
      End If
      '
      myDoc.write StrConv(myHTTP.responseBody, vbUnicode)
      myinnerText = myDoc.body.innerText
      Select Case True
        Case InStrRev(myinnerText, vbCrLf & "前へ") > 0
          myinnerText = Left(myinnerText, InStrRev(myinnerText, vbCrLf & "前へ"))
        Case InStrRev(myinnerText, vbCrLf & "次へ") > 0
          myinnerText = Left(myinnerText, InStrRev(myinnerText, vbCrLf & "次へ"))
        Case InStrRev(myinnerText, vbCrLf & "ニューストップ") > 0
          myinnerText = Left(myinnerText, InStrRev(myinnerText, vbCrLf & "ニューストップ"))
      End Select
      '
      myinnerText = Replace(myinnerText, vbCrLf, vbLf, 1, 1)
      myLead = "　" & Left(myinnerText, InStr(myinnerText, vbCr) - 1)
      myText = Replace(myinnerText, vbCrLf & vbCrLf, "")
      '
      Cells(r, "A").Value = myLead ' 記事の見出し
      Cells(r, "B").Value = "　" & myText & vbLf ' 記事の本文
    End If
    DoEvents
  Next ' r
  '
  ActiveSheet.Range("B1").Select
  Set myDoc = Nothing
End Sub ' MyXlNhkPage *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlNhkDetl(i As Long, c As Long, rr As Variant, myHTTP As Variant, myIE As Variant)
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim j As Long
  Dim r As Long
  Dim myURL As String
  Dim myinnerText As String
  Dim myStatusBar As String
  Dim myLead As String
  Dim myText As String
  Dim myString As String
  '
  Dim myTags As Variant ' DispHTMLElementCollection
  Dim myTag As Variant ' HTMLDivElement
  '
  c = c + 1
  For r = 2 To rr(i + 1)
    c = c + 1
    If Len(Cells(r, "C").Value) <> 0 Then
      With myIE
        .Navigate "about:blank"
        .Visible = False ' True
        Do While .Busy
          DoEvents
        Loop
        myStatusBar = "●読み込み中：" & c * 100 \ rr(0) & "%　"
        myStatusBar = myStatusBar & ActiveSheet.Name & " "
        myStatusBar = myStatusBar & r & "/" & rr(i + 1) & "行　"
        myStatusBar = myStatusBar & i + 1 & "/" & UBound(rr) & "頁"
        Application.StatusBar = "MyXlNhkDetl: " & myStatusBar
        DoEvents
        Set myDoc = .Document
      End With
      '
      myURL = Cells(r, "C").Value
      Call myHTTP.Open("GET", myURL, False)
      On Error Resume Next
      myHTTP.Send
      If myHTTP.readyState <> 4 Then ' 4:READYSTATE_COMPLETE
        myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
        myStatusBar = myStatusBar & "myHTTP.readyState: " & myHTTP.readyState & vbCr
        myStatusBar = myStatusBar & "URL: " & myURL
        MsgBox myStatusBar, vbOKOnly, "MyXlNhkDetl"
        Exit Sub
      End If
      Cells(r, "C").Select
      If myHTTP.Status <> 200 Then
        'myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
        'myStatusBar = myStatusBar & "myHTTP.Status: " & myHTTP.Status & vbCr
        'myStatusBar = myStatusBar & "URL: " & myURL
        'MsgBox myStatusBar, vbOKOnly, "MyXlNhkDetl"
        'Exit Sub
        Rem myText = "ページを表示できませんでした。" ' 記事がない場合（記事が未入力）
        myText = "●" & Cells(r, "B").Text
        Cells(r, "C").Value = myText & vbLf
        '
        Cells(r, "A").Select
        Selection.Hyperlinks(1).Address = Replace(myURL, "/d", "/k")
      Else
        myText = StrConv(myHTTP.responseBody, vbUnicode)
        myText = Replace(myText, " src=", " Zzzsrc=")
        myText = Replace(myText, "<script", "<!-- script")
        myDoc.write myText
        '
        Set myTags = myDoc.getElementsByTagName("div")
        If myTags.Length = 3 Then
          j = 0
        Else
          j = 1
        End If
        myText = Cells(r, "A").Text & vbLf ' 記事の見出し
        myText = myText & myTags.Item(j).innerText & vbLf ' 記事の本文
        myText = myText & "(" & myTags.Item(j + 1).innerText & ")" ' 記事の日付
        Cells(r, "C").Value = myText & vbLf
      End If
      On Error GoTo 0
    End If
    DoEvents
  Next ' r
  '
  ActiveSheet.Range("B1").Select
  Set myDoc = Nothing
End Sub ' MyXlNhkDetl *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlNhkBttnMyOk(Optional myDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem コマンドボタン[OK]OnAction処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  CommandBars("MyXlNhk").Controls(1).FaceId = 459
End Sub ' MyXlNhkBttnMyOk *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlNhkBttnMyCancel(Optional myDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem コマンドボタン[キャンセル]OnAction処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  CommandBars("MyXlNhk").Controls(1).FaceId = 330
End Sub ' MyXlNhkBttnMyCancel *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlNhkBttnMyDetail(Optional myDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [もっと詳しく]ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  With CommandBars("MyXlNhk").Controls(2)
    If .FaceId = 6963 Then
      .FaceId = 220
      .TooltipText = "[もっと詳しく]も取り込む。"
    Else
     .FaceId = 6963
     .TooltipText = "[もっと詳しく]は取り込まない。"
    End If
  End With
End Sub ' MyXlNhkBttnMyDetail *----*----*    *----*----*    *----*----*    *----*----*