Sub MyXlSnnn()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 島根日日新聞サイト 取り込み処理
  Rem （HttpRequest使用）
  Rem 作譜：Hitrock Camellia Shinopy
  Rem 言語：Excel VBA
  Rem 機能...
  Rem   島根日日新聞サイトのニュース記事を取り込みし、
  Rem   Excelシートに書き込みする。
  Rem 注記...
  Rem   1. MyXlSnnnを起動して使用｡
  Rem   2. 文字列変数「myIEblank」の値指定は、IEのバージョンによって変更要！
  Rem   3. なぜか、IEの「Visible = False」が機能しない場合があるので、
  Rem      ExcelのWindowStateの操作で対処。
  Rem   4. サイトのページ内容を取り損ねることがあるため、
  Rem      ページを読み込む時に、DoEvents関数で処理を一時停止させる。
  Rem     （これまでの試行により、前のページに戻る時は、不要と思われる。）
  Rem   5. 音声で処理終了を知らせるため、[コントロール パネル]の[音声認識]にある
  Rem      [音声合成]タブの[音声の選択]で[LH Kenji]または[LH Naoko]を指定しておくこと。
  Rem   6. ポップアップメニューのコマンドボタンに付加したOnActionプロパティのプロシージャには、
  Rem      パラメーターを指定していない。（ExcelVBAでは指定可能だが、他のOffice製品では不可のため。）
  Rem 履歴...
  Rem   第1版：2008/02/26：作成。
  Rem   第2版：2008/08/23：FaceIdの指定を変更。「459」=>「964」（Excel2007に対応）。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 参照設定する場合...
  Rem   Microsoft Internet Controls
  Rem   Microsoft HTML Object Library
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myHTTP As Variant ' IXMLHTTPRequest
  Dim myIE As Variant ' InternetExplorer
  Dim myTags As Variant ' DispHTMLElementCollection
  '
  Dim myStream As Variant ' Stream
  Dim mySource As String
  Const AdBinary = 1
  Const AdTypeText = 2
  '
  Dim myTitle As String
  Dim rr As Variant
  Dim myText As String
  Dim myMax As Long
  Dim mySheetFirst As Long
  '
  Dim myURL As String
  Dim myHref As String
  Dim myIEblank As String
  Dim myStatusBar As String
  '
  Dim i As Long
  Dim c As Long
  Dim myAns  As Long
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myTitle = "MyXlSnnn"
  Call MyXlSnnnPopUp(myTitle)
  '
  Select Case CommandBars(myTitle).Controls(1).FaceId
    Case 964: myAns = vbOK
    Case 330: myAns = vbCancel
  End Select
  '
  If myAns = vbCancel Then GoTo MyXlSnnnSubExit
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem 島根日日新聞サイトトップページ
  myURL = "http://www.shimanenichinichi.co.jp/"
  ' myIEblank = "about:blank" ' IEのバージョンによって変更要！
  myIEblank = "about:" ' IEのバージョンによって変更要！
  '
  ActiveSheet.Range("A1").Select
  Application.CommandBars("Task Pane").Visible = False
  myStatusBar = "□島根日日新聞サイト 取り込み開始"
  If CommandBars(myTitle).Controls(2).FaceId = 220 Then
    myStatusBar = myStatusBar & "（見出し・本文とも取り込み）"
  Else
    myStatusBar = myStatusBar & "（見出しのみ取り込み）"
  End If
  Application.StatusBar = myTitle & ": " & myStatusBar
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myHTTP = CreateObject("MSXML2.XMLHTTP") ' ("Microsoft.XMLHTTP")
  Set myStream = CreateObject("ADODB.Stream")
  Set myIE = CreateObject("InternetExplorer.Application")
  '
  With myIE
    .Navigate "about:blank"
    '.Document.Charset = "unicode"
    .Visible = False ' True
    Do While .Busy
      DoEvents
    Loop
    '
    Application.WindowState = xlMinimized
    Application.WindowState = xlNormal
    DoEvents
  End With
  '
  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, myTitle
    GoTo MyXlSnnnSubExit
  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, myTitle
    GoTo MyXlSnnnSubExit
  End If
  '
  myStream.Type = AdBinary
  myStream.Open
  myStream.write (myHTTP.responseBody)
  myStream.Position = 0
  myStream.Type = AdTypeText
  myStream.Charset = "utf-8" ' "x-sjis" ' "EUC-JP" ' "iso-2022-jp"
  mySource = myStream.ReadText()
  ' Call myStream.SaveToFile(myFile, 2)
  myStream.Close
  mySource = Mid(mySource, InStr(mySource, "<!-- ▼カテゴリメニュー▼ -->"))
  mySource = Left(mySource, InStr(mySource, "<!-- ▼トップニュース▼ -->") - 1)
  myIE.document.write mySource
  '
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myTags = myIE.document.getElementsByTagName("a")
  myMax = myTags.Length
  ReDim rr(myMax + 1)
  '
  Range("A1").Select
  mySheetFirst = ActiveSheet.Index
  '
  c = Worksheets.Count - ActiveSheet.Index + 1
  If c < myMax Then
    c = myMax - c
    For i = 1 To c
      Worksheets.Add After:=Sheets(Worksheets.Count), Count:=1
    Next ' i
    Sheets(mySheetFirst).Activate
  End If
  '
  For i = 1 To myMax
    Range("A1").Value = "島根日日新聞"
    Cells(2, "A").Select
    Cells(2, "A").Interior.ColorIndex = 34 ' 薄い水色
    ActiveSheet.Name = myTags(i - 1).innerText
    myHref = Replace(myTags(i - 1).href, myIEblank & "/", myURL)
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(2, "A"), _
      Address:=myHref, TextToDisplay:="　　○" & myTags(i - 1).innerText
    Range("A1").Select
    '
    On Error Resume Next
    ActiveSheet.Next.Select
    On Error GoTo 0
    DoEvents
  Next ' i
  '
  Sheets(mySheetFirst).Activate
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Application.ScreenUpdating = False
  For i = 1 To myMax
    Call MyXlSnnnPage(myTitle, myURL, i, myMax, rr, myHTTP, myStream, myIE)
    '
    On Error Resume Next
    ActiveSheet.Next.Select
    On Error GoTo 0
    DoEvents
  Next ' i
  Sheets(mySheetFirst).Activate
  Application.ScreenUpdating = True
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem ニュース本文の取り込み
  Application.ScreenUpdating = False
  If CommandBars(myTitle).Controls(2).FaceId = 220 Then
    rr(0) = 0
    rr(myMax + 1) = 0
    For i = 1 To myMax
      rr(myMax + 1) = rr(myMax + 1) + rr(i)
    Next ' i
    For i = 1 To myMax
      Call MyXlSnnnBody(myTitle, myURL, i, myMax, rr, myHTTP, myStream, myIE)
      '
      On Error Resume Next
      ActiveSheet.Next.Select
      On Error GoTo 0
      DoEvents
    Next ' i
  End If
  Sheets(mySheetFirst).Activate
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyXlSnnnSubExit:
  Application.ScreenUpdating = True
  myStatusBar = "処理が終了しました。"
  Application.StatusBar = myTitle & ": " & myStatusBar & Now()
  Application.Speech.Speak myStatusBar, False
  '
  On Error Resume Next
  Rem myIE.Visible = True
  myIE.Quit
  CommandBars(myTitle).Delete
  On Error GoTo 0
  Beep
  '
  Set myHTTP = Nothing
  Set myIE = Nothing
  Set myTags = Nothing
  Set myStream = Nothing
End Sub ' MyXlSnnn *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlSnnnPage(myTitle As String, myURL As String, i As Long, myMax As Long, rr As Variant, myHTTP As Variant, myStream As Variant, myIE As Variant)
  Dim myTags As Variant ' DispHTMLElementCollection
  Dim myTag As Variant ' HTMLDivElement
  '
  Dim mySource As String
  Const AdBinary = 1
  Const AdTypeText = 2
  '
  Dim myText As String
  Dim myHref As String
  Dim myLength As Long
  Dim myIEblank As String
  Dim myStatusBar As String
  '
  Dim c As Long
  Dim myDatePrev As String
  Dim myDateCurr As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  'myIEblank = "about:blank" ' IEのバージョンによって変更要！
  myIEblank = "about:" ' IEのバージョンによって変更要！
  '
  With myIE
    .Navigate "about:blank"
    '.Document.Charset = "unicode"
    .Visible = False ' True
    Do While .Busy
      DoEvents
    Loop
    '
    myStatusBar = "□島根日日新聞サイト 取り込み中：" & " ○ " & ActiveSheet.Name
    If CommandBars(myTitle).Controls(2).FaceId = 220 Then
      myStatusBar = myStatusBar & "（見出し・本文とも取り込み）" & " "
      myStatusBar = myStatusBar & i & "/" & myMax & "頁"
    Else
      myStatusBar = myStatusBar & "（見出しのみ取り込み）" & " "
      myStatusBar = myStatusBar & i & "/" & myMax & "頁"
    End If
    Application.StatusBar = myTitle & ": " & myStatusBar
    DoEvents
  End With
  '
  Call myHTTP.Open("GET", Cells(2, "A").Hyperlinks(1).Address, 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, myTitle
    GoTo MyXlSnnnPageSubExit
  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, myTitle
    GoTo MyXlSnnnPageSubExit
  End If
  '
  myStream.Type = AdBinary
  myStream.Open
  myStream.write (myHTTP.responseBody)
  myStream.Position = 0
  myStream.Type = AdTypeText
  myStream.Charset = "utf-8" ' "x-sjis" ' "EUC-JP" ' "iso-2022-jp"
  mySource = myStream.ReadText()
  ' Call myStream.SaveToFile(myFile, 2)
  myStream.Close
  myText = Replace(myText, "<LINK ", "<!-- LINK ", 1, 1)
  mySource = Replace(mySource, "<title>", " --> <title>", 1, 1)
  mySource = Replace(mySource, "<img ", "<!-- img ", 1, 2)
  mySource = Replace(mySource, "<script ", "<!-- script ", 1, 1)
  mySource = Replace(mySource, " src=", " Zzzsrc=")
  myIE.document.write mySource
  '
  c = 0
  rr(i) = 2
  '
  Set myTags = myIE.document.getElementsByTagName("tr")
  myLength = myTags.Length
  If myLength = 0 Then
    Cells(c, "B").Value = "現在、掲載記事がありません。"
    Columns("A:A").ColumnWidth = 70#
    Columns("A:A").WrapText = True
    Columns("B:B").ColumnWidth = 70#
  Else
    myDatePrev = myTags.Item(0).FirstChild.innerText
    For Each myTag In myTags
      c = c + 1
      myStatusBar = "□島根日日新聞サイト 取り込み中："
      myStatusBar = myStatusBar & " ○ " & ActiveSheet.Name & " " & c & "/" & myLength & "件 "
      myStatusBar = myStatusBar & i & "/" & myMax & "頁"
      Application.StatusBar = myTitle & ": " & myStatusBar
      '
      myDateCurr = myTag.childNodes(0).innerText
      If myDateCurr <> myDatePrev Then
        rr(i) = rr(i) + 1
        myDatePrev = myTag.childNodes(0).innerText
      End If
      '
      myText = myDateCurr & " " & myTag.childNodes(1).innerText & " "
      If myTag.childNodes(1).Children.Length = 0 Then
        c = c - 1
        myLength = myTags.Length - 1
      Else
        rr(i) = rr(i) + 1
        myHref = Replace(myTag.childNodes(1).Children(0).href, myIEblank, myURL)
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(rr(i), "A"), Address:=myHref, TextToDisplay:=myText
      End If
      ActiveSheet.Range("A1").Select
      Columns("A:A").ColumnWidth = 70#
      Columns("B:B").ColumnWidth = 70#
      Columns("A:B").WrapText = True
      DoEvents
    Next ' myTag
  End If
MyXlSnnnPageSubExit:
  Set myTags = Nothing
  Set myTag = Nothing
End Sub ' MyXlSnnnPage *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlSnnnBody(myTitle As String, myURL As String, i As Long, myMax As Long, rr As Variant, myHTTP As Variant, myStream As Variant, myIE As Variant)
  Dim myTags As Variant ' DispHTMLElementCollection
  '
  Dim mySource As String
  Const AdBinary = 1
  Const AdTypeText = 2
  '
  Dim myText As String
  Dim myStatusBar As String
  '
  Dim r As Long
  Dim c As Long
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  ActiveWindow.Zoom = 75
  '
  For r = 4 To rr(i)
    Cells(r, "A").Select
    If CommandBars(myTitle).Controls(3).FaceId = 220 Then
      If Len(Cells(r, "A").Value) = 0 Then Exit For
    End If
    '
    If Len(Cells(r, "A").Value) <> 0 Then
      With myIE
        .Navigate "about:blank"
        .Visible = False ' True
        Do While .Busy
          DoEvents
        Loop
        DoEvents
      End With
      '
      Call myHTTP.Open("GET", Cells(r, "A").Hyperlinks(1).Address, 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, myTitle
        GoTo MyXlSnnnBodySubExit
      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, myTitle
        GoTo MyXlSnnnBodySubExit
      End If
      '
      mySource = StrConv(myHTTP.responseBody, vbUnicode)
      myStream.Type = AdBinary
      myStream.Open
      myStream.write (myHTTP.responseBody)
      myStream.Position = 0
      myStream.Type = AdTypeText
      myStream.Charset = "utf-8" ' "x-sjis" ' "EUC-JP" ' "iso-2022-jp"
      mySource = myStream.ReadText()
      ' Call myStream.SaveToFile(myFile, 2)
      myStream.Close
      '
      mySource = Replace(mySource, "<LINK ", "<!-- LINK ", 1, 1)
      mySource = Replace(mySource, "<title>", " --> <title>", 1, 1)
      mySource = Replace(mySource, "<img ", "<!-- img ", 1, 1)
      mySource = Replace(mySource, "<script ", "<!-- script ", 1, 1)
      mySource = Replace(mySource, " src=", " Zzzsrc=")
      myIE.document.write mySource
      '
      Set myTags = myIE.document.getElementById("news")
      If myTags.Children.Length <> 0 Then
        myText = Replace(myTags.innerText, ActiveSheet.Name, "", 1, 1)
        myText = Replace(myText, "  " & vbCrLf, "")
        myText = Replace(myText, " " & vbCrLf & vbCrLf, "")
        myText = Replace(myText, "　" & " " & vbCrLf, "")
        myText = Replace(myText, "　" & vbCrLf, "")
        Cells(r, "B").Value = myText
      Else
        Cells(r, "B").Value = "この記事は取り込みできませんでした。"
      End If
      '
      c = rr(0) + r
      myStatusBar = "□島根日日新聞サイト 本文 取り込み中 "
      myStatusBar = myStatusBar & c * 100 \ rr(myMax + 1) & "%　"
      myStatusBar = myStatusBar & r & "/" & rr(i) & "行　"
      myStatusBar = myStatusBar & i & "/" & myMax & "頁"
      Application.StatusBar = myTitle & ": " & myStatusBar
    End If
    DoEvents
  Next ' r
  rr(0) = rr(0) + rr(i)
  ActiveSheet.Range("B1").Select
  DoEvents
  ' *----*----*    *----*----*    *----*----*    *----*----*
  '
MyXlSnnnBodySubExit:
  Set myTags = Nothing
  myStatusBar = "□島根日日新聞サイト 本文 取り込み中 "
  myStatusBar = myStatusBar & rr(0) * 100 \ rr(myMax + 1) & "%　"
  myStatusBar = myStatusBar & rr(i) & "/" & rr(i) & "行　"
  myStatusBar = myStatusBar & i & "/" & myMax & "頁"
  Application.StatusBar = myTitle & ": " & myStatusBar
End Sub ' MyXlSnnnBody *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlSnnnPopUp(myTitle As String)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem ポップアップ表示処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myCmmdBar As CommandBar
  Dim myCtrlBttn As CommandBarControl
  Dim myCtrlBttnDeTail As CommandBarControl
  Dim myCtrlBttnLastest 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
  '
  On Error Resume Next
  CommandBars(myTitle).Delete
  On Error GoTo 0
  '
  Set myCmmdBar = CommandBars.Add(Name:=myTitle, 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 myCtrlBttnLastest = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=3, Temporary:=True)
  Set myCtrlBttnOk = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=4, Temporary:=True)
  Set myCtrlBttnCancel = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=5, Temporary:=True)
  '
  myMsg = myTitle & vbCrLf & vbCrLf
  myMsg = myMsg & "島根日日新聞サイト" & vbCrLf
  myMsg = myMsg & "取り込み処理" & vbCrLf & vbCrLf
  '
  With myCtrlBttn
    .DescriptionText = "島根日日新聞サイト 取り込み処理 ポップアップメニュー"
    .Style = msoButtonIconAndWrapCaption
    .Caption = myMsg & "処理を実行しますか？"
    .TooltipText = "処理を実行しますか？"
    .FaceId = 1089
    myFaceId = .FaceId
  End With
  '
  With myCtrlBttnDeTail
    .DescriptionText = "[ニュースの本文も取り込む]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "ニュースの本文も取り込む"
    .TooltipText = "ニュースの本文は取り込まない。"
    .FaceId = 6963
    .OnAction = "MyXlSnnnBttnMyDetail"
  End With
  '
  With myCtrlBttnLastest
    .DescriptionText = "[最新日のみ本文を取り込む]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "最新日のみ本文を取り込む"
    .TooltipText = "最新日のみ本文を取り込む。"
    .FaceId = 220
    .OnAction = "MyXlSnnnBttnMyLastest"
  End With
  '
  With myCtrlBttnOk
    .DescriptionText = "[OK]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "OK"
    .TooltipText = "処理をを実行します。"
    .FaceId = 964
    .OnAction = "MyXlSnnnBttnMyOk"
  End With
  '
  With myCtrlBttnCancel
    .DescriptionText = "[キャンセル]ボタン"
    .Style = msoButtonIconAndCaption
    .Caption = "キャンセル" & String(12, "　")
    .TooltipText = "処理を中止します。"
    .FaceId = 330
    .OnAction = "MyXlSnnnBttnMyCancel"
  End With
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  x = -1: y = -1
  myFaceId = myCmmdBar.Controls(1).FaceId
  Beep
  '
  Do
    On Error Resume Next
    If x = -1 Then
      myCmmdBar.ShowPopup
    Else
      myCmmdBar.ShowPopup x, y
    End If
    On Error GoTo 0
    DoEvents
    Select Case myCmmdBar.Controls(1).FaceId
      Case 964, 330 ' 実行／キャンセル
        Exit Do
      Case 220, 6963 ' [チェックボックス]オン・オフ
        x = myCmmdBar.Left
        y = myCmmdBar.Top
        myCmmdBar.Controls(1).FaceId = myFaceId
      Case Else
        x = -1: y = -1
    End Select
  Loop
End Sub ' MyXlSnnnPopUp *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlSnnnBttnMyOk(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem コマンドボタン[OK]OnAction処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  CommandBars("MyXlSnnn").Controls(1).FaceId = 964
End Sub ' MyXlSnnnBttnMyOk *----*----*    *----*----*    *----*----*    *----*----*

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

Sub MyXlSnnnBttnMyDetail(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [ニュースの本文も取り込む]ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  With CommandBars("MyXlSnnn").Controls(2)
    If .FaceId = 6963 Then
      .FaceId = 220
      .TooltipText = "ニュースの本文も取り込む。"
    Else
     .FaceId = 6963
     .TooltipText = "ニュースの本文は取り込まない。"
    End If
  End With
  CommandBars("MyXlSnnn").Controls(1).FaceId = CommandBars("MyXlSnnn").Controls(3).FaceId
End Sub ' MyXlSnnnBttnMyDetail *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlSnnnBttnMyLastest(Optional MyDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [ニュースの本文も取り込む]ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  With CommandBars("MyXlSnnn").Controls(3)
    If .FaceId = 220 Then
      .FaceId = 6963
      .TooltipText = "総て本文を取り込む。"
    Else
     .FaceId = 220
     .TooltipText = "最新日のみ本文を取り込む。"
    End If
  End With
  CommandBars("MyXlSnnn").Controls(1).FaceId = CommandBars("MyXlSnnn").Controls(3).FaceId
End Sub ' MyXlSnnnBttnMyLastest *----*----*    *----*----*    *----*----*    *----*----*