Sub MyXlKanaloco()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 神奈川新聞サイト[カナロコトップ]ページ取り込み処理(HttpRequest使用)
  Rem 作譜:Hitrock Camellia Shinopy
  Rem 言語:Excel VBA
  Rem 機能...
  Rem   神奈川新聞サイトのページを取り込みし、
  Rem   Excelシートに書き込みする。
  Rem 注記...
  Rem   1. MyXlKanalocoを起動して使用。
  Rem   2. 「カナガワ事件簿」「デイリーベイスターズ」「カナロコJリーグ」は会員専用。(取り込みしない。)
  Rem   3. シート(1)から書き込みする。
  Rem 履歴...
  Rem   第1版:2006/08/27:作成。
  Rem   第2版:2006/09/10:処理が重複した箇所を修正。
  Rem   第3版:2006/11/11:IE7に対応:「about:blank」を「about:」に変更した箇所あり。
  Rem   第4版:2007/01/25:Excel2007に対応:バルーン表示を廃止、ポップアップメニューに変更。
  Rem   第5版:2007/02/01:コメントの取り込みを追加。
  Rem   第6版:2007/05/20:ハイパーリンク不具合・セル幅設定を修正。
  Rem   第7版:2007/05/23:ツールバー処理を別モジュールに修正。通信エラー処理をセル値設定に変更。
  Rem   第8版: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 myDoc As Variant ' MSHTML.HTMLDocument
  '
  Dim myDivMax As Long
  Dim myCount As Long
  Dim myText As String
  Dim myString As String
  '
  Dim myURL As String
  Dim myHref As String
  Dim myStatusBar As String
  '
  Dim myTitle As String
  Dim i  As Long
  Dim myAns  As Long
  Dim myCbox As Boolean
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myTitle = "MyXlKanaloco"
  Call MyXlKanalocoCmmdBar(myTitle)
  '
  Select Case CommandBars(myTitle).Controls(1).FaceId
    Case 964
      myAns = vbOK
    Case 330
      myAns = vbCancel
  End Select
  '
  If CommandBars(myTitle).Controls(2).FaceId = 220 Then
    myCbox = True
  Else
    myCbox = False
  End If
  '
  If myAns = vbCancel Then
    GoTo MyXlKanalocoSubExit
  End If
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem 神奈川新聞サイト[カナロコトップ]ページ
  myURL = "http://www.kanaloco.jp/top/index.html" ' "http://www.kanaloco.jp/"
  myDivMax = 5
  Dim rr(5) As Long
  For i = 0 To UBound(rr)
    rr(i) = 0
  Next ' i
  '
  Sheets(1).Activate
  ActiveSheet.Range("A1").Select
  Application.CommandBars("Task Pane").Visible = False
  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
    myStatusBar = "□神奈川新聞サイト[カナロコトップ]ページ 取り込み開始"
    If myCbox = True Then
      myStatusBar = myStatusBar & "(見出し・本文とも取り込み)"
    Else
      myStatusBar = myStatusBar & "(見出しのみ取り込み)"
    End If
    Application.StatusBar = myTitle & ": " & 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 = "接続できません。" & " readyState <> 4" & vbLf & myHTTP.statusText & vbLf
    myStatusBar = myStatusBar & "readyState: " & myHTTP.readyState & vbLf
    myStatusBar = myStatusBar & "URL: " & myURL
    ActiveCell.Value = myStatusBar
    ActiveCell.ColumnWidth = 70#
    GoTo MyXlKanalocoSubExit
  End If
  If myHTTP.Status <> 200 Then
    myStatusBar = "接続できません。" & " Status <> 200" & vbLf & myHTTP.statusText & vbLf
    myStatusBar = myStatusBar & "readyState: " & myHTTP.readyState & vbLf
    myStatusBar = myStatusBar & "URL: " & myURL
    ActiveCell.Value = myStatusBar
    ActiveCell.ColumnWidth = 70#
    GoTo MyXlKanalocoSubExit
  End If
  '
  myString = "<div id=" & Chr(34) & "partOfficeblog" & Chr(34) & ">"
  myText = Replace(myHTTP.responseText, "<div class=" & Chr(34) & "partOfficeblog" & Chr(34) & ">", myString)
  myText = Replace(myText, "<script ", "<!-- script ")
  myText = Replace(myText, " src=", " Zzzsrc=")
  '
  myDoc.write myText
  myDoc.Title = myURL
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  If Worksheets.Count < myDivMax Then
    myCount = myDivMax - Worksheets.Count
    For i = 1 To myCount
      Worksheets.Add After:=Sheets(Worksheets.Count), Count:=1
    Next ' i
  End If
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Application.ScreenUpdating = False
  Sheets(1).Activate
  ActiveSheet.Range("A1").Select
  '
  Call MyXlKanalocoPage(rr, myDoc)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Sheets(1).Activate
  ActiveSheet.Range("A1").Select
  Rem ニュース本文の取り込み
  If myCbox = True Then
    Call MyXlKanalocoBody(rr, myHTTP, myIE)
  End If
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyXlKanalocoSubExit:
  On Error Resume Next
  Application.ScreenUpdating = True
  Sheets(1).Activate
  '
  Rem myIE.Visible = True
  myIE.Quit
  CommandBars(myTitle).Delete
  Set myHTTP = Nothing
  Set myIE = Nothing
  Set myDoc = Nothing
  On Error GoTo 0
  '
  If myAns = vbCancel Then Exit Sub
  myStatusBar = "処理が終了しました。"
  Application.StatusBar = myTitle & ": " & myStatusBar & Now()
  Application.Speech.Speak myStatusBar, False
  Beep
End Sub ' MyXlKanaloco *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlKanalocoPage(rr As Variant, myDoc As Variant)
  Dim myTagDivs As Variant ' DispHTMLElementCollection
  Dim myTagDiv As Variant ' HTMLDivElement
  Dim mySubTags As Variant ' DispHTMLElementCollection
  Dim mySubTag As Variant ' HTMLHeaderElement
  '
  Dim myText As String
  Dim myString As String
  '
  Dim myURL As String
  Dim myHref As String
  Dim myStatusBar As String
  '
  Dim i  As Long
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myURL = myDoc.Title
  '
  Set myTagDivs = myDoc.getElementsByTagName("div")
  For Each myTagDiv In myTagDivs
    myStatusBar = "□神奈川新聞サイト[カナロコトップ]ページ 取り込み中:" & myTagDiv.ID
    Application.StatusBar = "MyXlKanaloco: " & myStatusBar
    myTagDiv.Title = myURL
    '
    Select Case myTagDiv.ID
      Case "naviNews", "naviSports", "naviLocal", "naviUninet", "naviLive", "naviCommodity"
        myTagDiv.Title = Replace(myURL, "top/index.html", "")
        rr(0) = 1
        i = rr(0)
        Sheets(i).Activate
        If rr(i) = 0 Then
          ActiveSheet.Range("A1").Select
          ActiveSheet.Name = "主要コンテンツ"
        End If
        '
        Call MyXlKanalocoTags("h3", "li", rr, myTagDiv)
        ' *----*----*    *----*----*    *----*----*    *----*----*
      Case "partTopnews", "partPhotonews"
        rr(0) = 2
        i = rr(0)
        Sheets(i).Activate
        If rr(i) = 0 Then
          ActiveSheet.Range("A1").Select
          ActiveSheet.Name = "ニュース(1段目)"
        End If
        '
        Call MyXlKanalocoTags("h3", "h4", rr, myTagDiv)
        ' *----*----*    *----*----*    *----*----*    *----*----*
      Case "subPartSocial", "subPartPolitics", "subPartUSForce", "subPartEconomics", _
        "subPartCulture", "subPartEducation", "subPartLife"
        rr(0) = 3
        i = rr(0)
        Sheets(i).Activate
        If rr(i) = 0 Then
          ActiveSheet.Range("A1").Select
          ActiveSheet.Name = "ニュース(2段目)"
        End If
        '
        Call MyXlKanalocoTags("h4", "li", rr, myTagDiv)
        ' *----*----*    *----*----*    *----*----*    *----*----*
      Case "partSportsnews", "partCasefiles"
        rr(0) = 2
        i = rr(0)
        Sheets(i).Activate
        If rr(i) = 0 Then
          ActiveSheet.Range("A1").Select
          ActiveSheet.Name = "ニュース(2段目)"
        End If
        '
        Call MyXlKanalocoTags("h3", "li", rr, myTagDiv)
        ' *----*----*    *----*----*    *----*----*    *----*----*
      Case "partSerial"
        rr(0) = 4
        i = rr(0)
        Sheets(i).Activate
        If rr(i) = 0 Then
          ActiveSheet.Range("A1").Select
        End If
        '
        Call MyXlKanalocoTags("h3", "li", rr, myTagDiv)
        ' *----*----*    *----*----*    *----*----*    *----*----*
      Case "partOfficeblog"
        rr(0) = 5
        i = rr(0)
        Sheets(i).Activate
        If rr(i) = 0 Then
          ActiveSheet.Range("A1").Select
        End If
        '
        Call MyXlKanalocoTags("h3", "li", rr, myTagDiv)
        ' *----*----*    *----*----*    *----*----*    *----*----*
      Case "naviToday"
        rr(0) = 1
        i = rr(0)
        Sheets(i).Activate
        If rr(i) = 0 Then
          ActiveSheet.Range("A1").Select
          ActiveSheet.Name = "主要コンテンツへのリンク"
        End If
        '
        Set mySubTags = myTagDiv.getElementsByTagName("h2")
        Cells(1, "A").Value = "神奈川新聞社"
        Cells(1, "B").Value = myTagDiv.innerText
        ' *----*----*    *----*----*    *----*----*    *----*----*
      Case "partWeatherReport"
        rr(0) = 2
        i = rr(0)
        Sheets(i).Activate
        If rr(i) = 0 Then
          ActiveSheet.Range("A1").Select
          ActiveSheet.Name = ActiveSheet.Name = "ニュース(1段目)"
        End If
        '
        Call MyXlKanalocoTags("h3", "", rr, myTagDiv)
        ' *----*----*    *----*----*    *----*----*    *----*----*
    End Select
    '
    ActiveWindow.SmallScroll up:=rr(i)
    ActiveSheet.Range("A1").Select
    Columns("A:A").ColumnWidth = 50#
    Columns("B:B").ColumnWidth = 70#
    Columns("C:C").ColumnWidth = 100#
    Columns("A:C").WrapText = True
    DoEvents
  Next ' myTagDiv
End Sub ' MyXlKanalocoPage *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlKanalocoTags(myTag1 As String, myTag2 As String, rr As Variant, myTagDiv As Variant)
  Dim mySubTags As Variant ' DispHTMLElementCollection
  Dim mySubTag As Variant ' HTMLHeaderElement
  '
  Dim myText As String
  Dim myString As String
  '
  Dim myURL As String
  Dim myHref As String
  Dim myStatusBar As String
  Dim myIEblank As String
  Dim i  As Long
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myIEblank = "about:blank/"
  Rem myIEblank = "about:/"  ????
  '
  myURL = myTagDiv.Title
  i = rr(0)
  '
  Set mySubTags = myTagDiv.getElementsByTagName(myTag1)
  Select Case myTagDiv.ID
    Case "naviToday"
      Rem
    Case Else
      rr(i) = rr(i) + 2
      Cells(rr(i), "A").Interior.ColorIndex = 34 ' 薄い水色
  End Select
  '
  Select Case myTagDiv.ID
    Case "naviToday"
      Rem
    Case "partTopnews", "partPhotonews"
      Cells(rr(i), "A").Value = "  ○" & " " & mySubTags.Item(0).childNodes.Item(0).alt
    Case "partWeatherReport"
      Cells(rr(i), "A").Value = "  ○" & " " & myTagDiv.childNodes.Item(0).innerText
    Case "partSerial"
      ActiveSheet.Name = mySubTags.Item(0).childNodes.Item(0).alt
      ActiveSheet.Name = Replace(ActiveSheet.Name, "神奈川新聞の", "")
      Cells(rr(i), "A").Value = "  ○" & " " & mySubTags.Item(0).childNodes.Item(0).alt
    Case "partOfficeblog"
      ActiveSheet.Name = mySubTags.Item(0).innerText
      ActiveSheet.Name = Replace(ActiveSheet.Name, "カナロコ", "")
      Cells(rr(i), "A").Value = "  ○" & " " & mySubTags.Item(0).innerText
    Case Else
      Cells(rr(i), "A").Value = "  ○" & " " & mySubTags.Item(0).innerText
  End Select
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Select Case myTagDiv.ID
    Case "naviToday"
      Rem
    Case "partWeatherReport"
      For Each mySubTag In myTagDiv.childNodes
        Select Case mySubTag.ID
          Case "subPartEast", "subPartWest"
            If Len(mySubTag.innerText) <> 0 And mySubTag.innerText <> " " Then
              rr(i) = rr(i) + 1
              Cells(rr(i), "A").Value = " " & mySubTag.innerText
              myText = Left(mySubTag.innerHTML, InStr(mySubTag.innerHTML, " Zzzsrc=") - 1)
              myText = Mid(myText, InStr(myText, " alt=") + 5)
              myText = vbCrLf & myText
              Cells(rr(i), "A").Value = Replace(Cells(rr(i), "A").Value, vbCrLf, myText, 1, 1)
            End If
        End Select
        DoEvents
      Next ' mySubTag
    Case Else
      Set mySubTags = myTagDiv.getElementsByTagName(myTag2)
      For Each mySubTag In mySubTags
        If Len(mySubTag.innerText) <> 0 And mySubTag.innerText <> " " Then
          rr(i) = rr(i) + 1
          myHref = Replace(mySubTag.childNodes(0).href, myIEblank, myURL)
          ActiveSheet.Hyperlinks.Add Anchor:=Cells(rr(i), "A"), Address:=myHref, TextToDisplay:=mySubTag.innerText
          '
          If ActiveSheet.Name <> "主要コンテンツ" Then
            If CommandBars("MyXlKanaloco").Controls(2).FaceId = 220 Then
              Cells(rr(i), "B").Value = myHref
            End If
          End If
        End If
        DoEvents
      Next ' mySubTag
  End Select
End Sub ' MyXlKanalocoTags *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlKanalocoBody(rr As Variant, myHTTP As Variant, myIE As Variant)
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim myTagDivs As Variant ' DispHTMLElementCollection
  Dim myTagDiv As Variant ' HTMLDivElement
  Dim mySubTags As Variant ' DispHTMLElementCollection
  Dim mySubTag As Variant ' HTMLHeaderElement
  '
  Dim myMax As Long
  Dim myText As String
  Dim myString As String
  '
  Dim myURL As String
  Dim myFlag As Boolean
  Dim myStatusBar As String
  '
  Dim i  As Long
  Dim r  As Long
  Dim c As Long
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  c = 0
  myMax = 0
  For i = 2 To Worksheets.Count
    myMax = myMax + rr(i)
  Next ' i
  '
  myStatusBar = "□神奈川新聞サイト[カナロコトップ]ページ 本文 取り込み開始"
  Application.StatusBar = "MyXlKanaloco: " & myStatusBar
  '
  For i = 2 To Worksheets.Count
    Sheets(i).Activate
    c = c + 1
    ActiveWindow.Zoom = 75
    For r = 2 To rr(i)
      myFlag = True
      c = c + 1
      With myIE
        .Navigate "about:blank"
        .Visible = False ' True
        Do While .Busy
          DoEvents
        Loop
        DoEvents
        Set myDoc = myIE.Document
      End With
      '
      If Len(Cells(r, "B").Value) = 0 Then
        myFlag = False
      Else
        myURL = Cells(r, "B").Value
        '
        Call myHTTP.Open("GET", myURL, False)
        Call myHTTP.Send
        If myHTTP.readyState <> 4 Then ' 4:READYSTATE_COMPLETE
          myStatusBar = "接続できません。" & " readyState <> 4" & vbLf & myHTTP.statusText & vbLf
          myStatusBar = myStatusBar & "readyState: " & myHTTP.readyState & vbLf
          myStatusBar = myStatusBar & "URL: " & myURL
          ActiveCell.Value = myStatusBar
          myFlag = False
        End If
        If myHTTP.Status <> 200 Then
          myStatusBar = "接続できません。" & " Status <> 200" & vbLf & myHTTP.statusText & vbLf
          myStatusBar = myStatusBar & "readyState: " & myHTTP.readyState & vbLf
          myStatusBar = myStatusBar & "URL: " & myURL
          ActiveCell.Value = myStatusBar
          myFlag = False
        End If
      End If
      '
      If myFlag = True Then
        myString = "<div id=" & Chr(34) & "partEntry" & Chr(34) & ">"
        myText = Replace(myHTTP.responseText, "<div class=" & Chr(34) & "partEntry" & Chr(34) & ">", myString)
        myText = Replace(myText, "<link ", "<!-- link ", 1, 1)
        myText = Replace(myText, "</head>", " --></head>", 1, 1)
        myText = Replace(myText, "<script ", "<!-- script ")
        myText = Replace(myText, " src=", " Zzzsrc=")
        myText = Replace(myText, "<img ", "<Zzzimg ")
        myDoc.write myText
        '
        Set myTagDivs = myDoc.getElementsByTagName("div")
        For Each myTagDiv In myTagDivs
          myStatusBar = "□神奈川新聞サイト[カナロコトップ]ページ 本文 取り込み中 "
          myStatusBar = myStatusBar & c * 100 \ myMax & "% "
          myStatusBar = myStatusBar & r & "/" & rr(i) & "行 "
          myStatusBar = myStatusBar & i & "/" & Worksheets.Count & "頁"
          Application.StatusBar = "MyXlKanaloco: " & myStatusBar
          '
          Select Case myTagDiv.ID
            Case "partEntry"
              myText = myTagDiv.innerText
              myText = Mid(myText, InStr(myText, vbCrLf) + 2)
              Cells(r, "B").Value = myText
              Rem Exit For
            Case "partCommentlist"
              myText = myTagDiv.innerText
              myText = Mid(myText, InStr(myText, vbCrLf) + 2)
              myText = Mid(myText, InStr(myText, "。") + 1)
              myText = Replace(myText, vbCrLf & vbCrLf & "[", " [", 1, 1)
              myText = Replace(myText, "]" & vbCrLf & vbCrLf, "]" & vbCrLf, 1, 1)
              Cells(r, "C").Value = myText
              Exit For
          End Select
          DoEvents
        Next ' myTagDiv
      End If
      DoEvents
    Next ' r
    ActiveSheet.Range("B1").Select
    DoEvents
  Next ' i
End Sub ' MyXlKanalocoBody *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlKanalocoCmmdBar(myTitle As String)
  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
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  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 myCtrlBttnOk = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=3, Temporary:=True)
  Set myCtrlBttnCancel = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=4, 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 = myTitle & "BttnMyDetail"
  End With
  '
  With myCtrlBttnOk
    .DescriptionText = "神奈川新聞サイト[カナロコトップ]ページ取り込み処理:[OK]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "OK"
    .TooltipText = "処理をを実行します。"
    .FaceId = 964
    .OnAction = myTitle & "BttnMyOk"
  End With
  '
  With myCtrlBttnCancel
    .DescriptionText = "神奈川新聞サイト[カナロコトップ]ページ取り込み処理:[キャンセル]ボタン"
    .Style = msoButtonIconAndCaption
    .Caption = "キャンセル"  & String(12, " ")
    .TooltipText = "処理を中止します。"
    .FaceId = 330
    .OnAction = myTitle & "BttnMyCancel"
  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
End Sub ' MyXlKanalocoCmmdBar *----*----*    *----*----*    *----*----*    *----*----*

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

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

Sub MyXlKanalocoBttnMyDetail(Optional myDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [ニュースの本文も取り込む]ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  With CommandBars("MyXlKanaloco").Controls(2)
    If .FaceId = 6963 Then
      .FaceId = 220
      .TooltipText = "ニュースの本文・コメントも取り込む。"
    Else
     .FaceId = 6963
     .TooltipText = "ニュースの本文・コメントは取り込まない。"
    End If
  End With
End Sub ' MyXlKanalocoBttnMyDetail *----*----*    *----*----*    *----*----*    *----*----*
inserted by FC2 system