Sub MyXlKsLocal()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 神奈川新聞サイト[ローカルニュース]（共同通信社）ページ取り込み処理
  Rem （HttpRequest使用）
  Rem 作譜：Hitrock Camellia Shinopy
  Rem 言語：Excel VBA
  Rem 機能...
  Rem   神奈川新聞サイトの[ローカルニュース]ページを取り込みし、
  Rem   Excelシートに書き込みする。
  Rem 注記...
  Rem   1. MyXlKsLocalを起動して使用｡
  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版：2007/05/25：作成。
  Rem   第2版：2007/06/05：ニュースの本文・コメントは取り込みを修正。
  Rem   第3版：2007/06/08：[最新日のみ本文を取り込む]を追加。
  Rem   第4版：2008/08/23：FaceIdの指定を変更。「459」=>「964」（Excel2007に対応）。
  Rem   第5版：2010/01/31：サイトの変更に対処。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 参照設定する場合...
  Rem   Microsoft Internet Controls
  Rem   Microsoft HTML Object Library
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myHTTP As Variant ' IXMLHTTPRequest
  Dim myIE As Variant ' InternetExplorer
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim myTags As Variant ' DispHTMLElementCollection
  '
  Dim myTitle As String
  Dim rr As Variant
  Dim myCount As Long
  Dim myText As String
  Dim myString As String
  Dim mySheetFirst As Long
  '
  Dim myURL As String
  Dim myURLkyodo As String
  Dim myIEblank As String
  Dim myStatusBar As String
  '
  Dim c As Long
  Dim i As Long
  Dim myMax As Long
  Dim myAns As Long
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myTitle = "MyXlKsLocal"
  Call MyXlKsLocalPopUp(myTitle)
  mySheetFirst = ActiveSheet.Index
  '
  Select Case CommandBars(myTitle).Controls(1).FaceId
    Case 964: myAns = vbOK
    Case 330: myAns = vbCancel
  End Select
  '
  If myAns = vbCancel Then GoTo MyXlKsLocalSubExit
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem 神奈川新聞サイト[ローカルニュース]ページ
  myURLkyodo = "http://news.kanaloco.jp/localnews/"
  myURL = myURLkyodo & "main/"
  ' myIEblank = "about:blank" ' IEのバージョンによって変更要！
  myIEblank = "about:" ' IEのバージョンによって変更要！
  '
  Application.CommandBars("Task Pane").Visible = False
  Sheets(1).Activate
  ActiveSheet.Range("A1").Select
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myHTTP = CreateObject("MSXML2.XMLHTTP") ' ("Microsoft.XMLHTTP")
  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
    myStatusBar = "□神奈川新聞サイト [ ローカルニュース ]ページ 取り込み開始"
    If CommandBars(myTitle).Controls(2).FaceId = 220 Then
      myStatusBar = myStatusBar & "（見出し・本文とも取り込み）"
    Else
      myStatusBar = myStatusBar & "（見出しのみ取り込み）"
    End If
    Application.StatusBar = myTitle & ": " & myStatusBar
    DoEvents
    Set myDoc = .Document
  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, "MyXlKsLocal"
    GoTo MyXlKsLocalSubExit
  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, "MyXlKsLocal"
    GoTo MyXlKsLocalSubExit
  End If
  '
  myText = myHTTP.responseText
  myText = Mid(myText, InStr(myText, "<!-- gNav start -->"))
  myText = Left(myText, InStrRev(myText, "<!-- gNav end -->") - 1)
  myText = Replace(myText, " class=", " id=")
  '
  myDoc.write myText
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  ' ジャンルの設定
  Set myTags = myDoc.getElementById("gNav")
  Set myTags = myTags.getElementsByTagName("ul")
  Set myTags = myTags.Item(0).Children(0)

  Set myTags = myTags.getElementsByTagName("a")
  '
  myMax = myTags.Length - 1
  CommandBars(myTitle).Controls(1).Parameter = CStr(myMax)
  '
  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
  ActiveSheet.Range("A1").Select
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  ReDim rr(myTags.Length)
  For i = 1 To UBound(rr) - 1
    Sheets(mySheetFirst + i - 1).Activate
    rr(i) = 2   ' 行位置の指定
    Cells(rr(i), "A").Select
    Cells(rr(i), "A").Interior.ColorIndex = 34 ' 薄い水色
    '
    Cells(rr(i), "A").Value = "　　○" & " " & myTags.Item(i).innerText
    ActiveSheet.Name = myTags.Item(i).innerText
    '
    Cells(rr(i), "B").Value = myTags.Item(i).href
  Next ' i
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Sheets(mySheetFirst).Activate
  ActiveSheet.Range("A1").Select
  '
  Application.ScreenUpdating = False
  For i = 1 To UBound(rr) - 1
    rr(0) = i
    Sheets(mySheetFirst + i - 1).Activate
    myDoc.Title = myURLkyodo
    Call MyXlKsLocalPage(rr, myHTTP, myIE)
  Next ' i
  Application.ScreenUpdating = True
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Sheets(mySheetFirst).Activate
  ActiveSheet.Range("A1").Select
  Rem ニュース本文の取り込み
  If CommandBars(myTitle).Controls(2).FaceId = 220 Then
    myDoc.Title = myURLkyodo
    Call MyXlKsLocalBody(rr, myHTTP, myIE)
  End If
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyXlKsLocalSubExit:
  Sheets(mySheetFirst).Activate
  myStatusBar = "処理が終了しました。"
  Application.StatusBar = myTitle & ": " & myStatusBar & Now()
  Application.Speech.Speak myStatusBar, False
  '
  On Error Resume Next
  Rem myIE.Visible = True
  myIE.Quit
  Application.ScreenUpdating = True
  CommandBars(myTitle).Delete
  On Error GoTo 0
  Beep
  '
  Set myHTTP = Nothing
  Set myIE = Nothing
  Set myDoc = Nothing
  Set myTags = Nothing
End Sub ' MyXlKsLocal *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlKsLocalPage(rr As Variant, myHTTP As Variant, myIE As Variant)
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim myTag As Variant ' DispHTMLElementCollection
  Dim myTags As Variant ' DispHTMLElementCollection
  Dim myTagsNews As Variant ' DispHTMLElementCollection
  Dim myTagsDate As Variant ' DispHTMLElementCollection
  Dim myText As String
  '
  Dim myURL As String
  Dim myURLkyodo As String
  Dim myHref As String
  Dim myIEblank As String
  Dim myStatusBar As String
  '
  Dim i As Long
  Dim c As Long
  Dim myDatePrev As String
  Dim myDateCurr As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  ' myIEblank = "about:blank" ' IEのバージョンによって変更要！
  myIEblank = "about:" ' IEのバージョンによって変更要！
  '
  i = rr(0)
  myURLkyodo = myIE.Document.Title
  '
  With myIE
    .Navigate "about:blank"
    .Visible = False ' True
    Do While .Busy
      DoEvents
    Loop
    DoEvents
    Set myDoc = myIE.Document
  End With
  myStatusBar = "□神奈川新聞サイト [ ローカルニュース ]ページ 取り込み中：" & ActiveSheet.Name
  myURL = Cells(2, "B").Value
  '
  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, "MyXlKsLocal"
    GoTo MyXlKsLocalPageSubExit
  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, "MyXlKsLocal"
    GoTo MyXlKsLocalPageSubExit
  End If
  '
  myText = myHTTP.responseText
  myText = Mid(myText, InStr(myText, "<!-- main start -->"))
  myText = Left(myText, InStrRev(myText, "<!-- main end -->") - 1)
  myText = Replace(myText, " class=", " id=")
  '
  myDoc.write myText
  '
  Set myTags = myDoc.getElementById("newsList")
  Set myTagsNews = myTags.getElementsByTagName("a")
  Set myTagsDate = myDoc.getElementById("newsList").Children
  '
  c = 0
  If myTags.Children.Length = 0 Then
    rr(i) = rr(i) + 1
    Cells(rr(i), "A").Select
    myText = "現在、掲載記事がありません。"
    myHref = Cells(2, "B").Value
    Cells(2, "B").Value = ""
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=myHref, TextToDisplay:=myText
    ActiveSheet.Range("A1").Select
    Columns("A:A").ColumnWidth = 70#
    Columns("B:B").ColumnWidth = 70#
  Else
    Cells(2, "B").Value = ""
    '
    myDatePrev = myTagsDate.Item(0).innerText
    myDatePrev = Left(myDatePrev, InStr(myDatePrev, "日" & vbCrLf))
    For Each myTag In myTagsNews
      c = c + 1
      myStatusBar = "□神奈川新聞サイト [ ローカルニュース ]ページ 取り込み中："
      myStatusBar = myStatusBar & " ○ " & ActiveSheet.Name & " " & c & "/" & myTags.Children.Length
      Application.StatusBar = "MyXlKsLocal: " & myStatusBar
      '
      myDateCurr = myTagsDate.Item(c - 1).innerText
      myDateCurr = Left(myDateCurr, InStr(myDateCurr, "日" & vbCrLf))
      If myDateCurr <> myDatePrev Then
        rr(i) = rr(i) + 1
        Cells(rr(i), "A").Select
        myDatePrev = myDateCurr
      End If
      '
      rr(i) = rr(i) + 1
      Cells(rr(i), "A").Select
      myText = myTagsDate.Item(c - 1).innerText
      myText = Replace(myText, vbCrLf, " ")
      myHref = myTagsNews.Item(c - 1).href
      '
      ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=myHref, TextToDisplay:=myText
      '
      ActiveWindow.SmallScroll up:=rr(i)
      ActiveSheet.Range("A1").Select
      Columns("A:A").ColumnWidth = 70#
      Columns("B:B").ColumnWidth = 70#
      DoEvents
    Next ' myTagDiv
  End If
MyXlKsLocalPageSubExit:
  Rem
End Sub ' MyXlKsLocalPage *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlKsLocalBody(rr As Variant, myHTTP As Variant, myIE As Variant)
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim myTags As Variant ' DispHTMLElementCollection
  '
  Dim myMax As Long
  Dim myText As String
  '
  Dim myURL As String
  Dim myURLkyodo As String
  Dim myStatusBar As String
  '
  Dim i  As Long
  Dim r  As Long
  Dim c As Long
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  i = rr(0)
  myURLkyodo = myIE.Document.Title
  '
  myMax = 0
  If CommandBars("MyXlKsLocal").Controls(3).FaceId = 220 Then
    For i = 1 To Worksheets.Count
      Sheets(i).Activate
      c = 2
      For r = 3 To rr(i)
        If Len(Cells(r, "A").Value) = 0 Then Exit For
        c = c + 1
      Next ' r
      rr(i) = c
      myMax = myMax + rr(i)
    Next ' i
  Else
    c = 0
    For i = 1 To Worksheets.Count
      myMax = myMax + rr(i)
    Next ' i
  End If
  '
  myStatusBar = "□神奈川新聞サイト [ ローカルニュース ]ページ 本文 取り込み開始"
  Application.StatusBar = "MyXlKsLocal: " & myStatusBar
  '
  For i = 1 To Worksheets.Count
    Sheets(i).Activate
    c = c + 2
    ActiveWindow.Zoom = 75
    For r = 3 To rr(i)
      Cells(r, "A").Select
      c = c + 1
      If CommandBars("MyXlKsLocal").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
          Set myDoc = myIE.Document
        End With
        myURL = Cells(r, "A").Hyperlinks(1).Address
        '
        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, "MyXlKsLocal"
          GoTo MyXlKsLocalBodySubExit
        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, "MyXlKsLocal"
          GoTo MyXlKsLocalBodySubExit
        End If
        '
        myText = myHTTP.responseText
        myText = Mid(myText, InStr(myText, "<!-- main start -->"))
        myText = Left(myText, InStrRev(myText, "<!-- main end -->") - 1)
        myDoc.write myText
        '
        Set myTags = myDoc.getElementById("newsbody")
        '
        myStatusBar = "□神奈川新聞サイト [ ローカルニュース ]ページ 本文 取り込み中 "
        myStatusBar = myStatusBar & c * 100 \ myMax & "%　"
        myStatusBar = myStatusBar & r & "/" & rr(i) & "行　"
        myStatusBar = myStatusBar & i & "/" & Worksheets.Count & "頁"
        Application.StatusBar = "MyXlKsLocal: " & myStatusBar
        '
        If myTags.Children.Length <> 0 Then
          Cells(r, "B").Value = myTags.innerText
        Else
          Rem 「この記事は削除されました。」の場合
          Set myTags = myDoc.getElementsByTagName("p")
          Cells(r, "B").Value = myTags.innerText
        End If
      End If
      DoEvents
    Next ' r
    ActiveSheet.Range("B1").Select
    DoEvents
  Next ' i
  ' *----*----*    *----*----*    *----*----*    *----*----*
  '
MyXlKsLocalBodySubExit:
  Rem
End Sub ' MyXlKsLocalBody *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlKsLocalPopUp(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
  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 = "MyXlKsLocalBttnMyDetail"
  End With
  '
  With myCtrlBttnLastest
    .DescriptionText = "[最新日のみ本文を取り込む]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "最新日のみ本文を取り込む"
    .TooltipText = "最新日のみ本文を取り込む。"
    .FaceId = 220
    .OnAction = "MyXlKsLocalBttnMyLastest"
  End With
  '
  With myCtrlBttnOk
    .DescriptionText = "[OK]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "OK"
    .TooltipText = "処理をを実行します。"
    .FaceId = 964
    .OnAction = "MyXlKsLocalBttnMyOk"
  End With
  '
  With myCtrlBttnCancel
    .DescriptionText = "[キャンセル]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "キャンセル" & String(12, "　")
    .TooltipText = "処理を中止します。"
    .FaceId = 330
    .OnAction = "MyXlKsLocalBttnMyCancel"
  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 ' MyXlKsLocalPopUp *----*----*    *----*----*    *----*----*    *----*----*

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

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

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

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