Sub MyXlChibaNp()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 千葉日報サイト 取り込み処理
  Rem 作譜:Hitrock Camellia Shinopy
  Rem 言語:Excel VBA
  Rem 機能...
  Rem   千葉日報サイトの記事を取り込みし、Excelシートに書き込みする。
  Rem 注記...
  Rem   1. MyXlChibaNpを起動して使用。
  Rem   2. 文字列変数「myIEblank」の値指定は、IEのバージョンによって変更要!
  Rem   3. なぜか、IEの「Visible = False」が機能しないので、
  Rem      ExcelのWindowStateの操作で対処。
  Rem 履歴...
  Rem   第1版:2007/03/04:作成。
  Rem   第2版:2007/05/06:「myIEblank」の値指定を修正。WindowState操作を追加。
  Rem   第3版:2007/06/18:プロシージャの変更。
  Rem   第4版:2007/11/16:再作成。
  Rem   第5版: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 myStream As Variant ' Stream
  Dim mySource As String
  '
  Dim myTags As Variant ' DispHTMLElementCollection
  Dim myTag As Variant ' HTMLHeaderElement
  Dim mySubTags As Variant ' DispHTMLElementCollection
  Dim mySubTag As Variant ' HTMLHeaderElement
  Dim mySubTag1 As Variant ' HTMLHeaderElement
  Dim mySubTag2 As Variant ' HTMLHeaderElement
  Dim mySubTag3 As Variant ' HTMLHeaderElement
  '
  Dim myTitle As String
  Dim myURL As String
  Dim mySubURL As String
  Dim myHref As String
  Dim myinnerText As String
  Dim myLink As Hyperlink
  '
  Dim myAns As Long
  Dim myMax As Long
  Dim mySheetName As String
  Dim myRow As Variant
  Dim myStatusBar As String
  Dim i As Long
  Dim j As Long
  Dim r As Long
  Dim c As Long
  Dim v As Variant
  Dim myString As String
  Dim myIEblank As String
  Dim mySheetArray As Variant
  Dim myLinks As String
  Dim myLinkArray As Variant
  Dim myCounts As String
  Dim myCountArray As Variant
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myTitle = "MyXlChibaNp"
  myIEblank = "about:blank" ' IEのバージョンによって変更要!
  ' myIEblank = "about:" ' IEのバージョンによって変更要!
  myURL = "http://www.chibanippo.co.jp/"
  myString = "千葉日報サイトマップ,県内ニューストップ,国内外ニューストップ,フォトニュース,"
  myString = myString & "スポーツトップ,忙人寸語,社説"
  mySheetArray = Split(myString, ",")
  '
  On Error Resume Next
  CommandBars(myTitle).Delete
  On Error GoTo 0
  '
  Call MyXlChibaNpCmmdBar(myTitle)
  myLinks = myURL & "sitemap/"
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Select Case CommandBars(myTitle).Controls(1).FaceId
    Case 964
      myAns = vbOK
    Case 330
      myAns = vbCancel
  End Select
  '
  If myAns = vbCancel Then Exit Sub
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Application.CommandBars("Task Pane").Visible = False
  ActiveSheet.Range("A1").Select
  For Each v In mySheetArray
    ActiveSheet.Name = v
    On Error Resume Next
    ActiveSheet.Next.Select
    If Err.Number <> 0 Then
      If v = mySheetArray(UBound(mySheetArray)) Then Exit For
      Worksheets.Add After:=Sheets(Worksheets.Count), Count:=1
      ActiveSheet.Name = v.Text
    End If
    On Error GoTo 0
    DoEvents
  Next ' v
  Sheets(mySheetArray(0)).Activate
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem サイトマップの取り込み処理
  myStatusBar = "□千葉日報サイト 取り込み開始!"
  Application.StatusBar = myTitle & ": " & myStatusBar
  Set myHTTP = CreateObject("MSXML2.XMLHTTP") ' ("Microsoft.XMLHTTP")
  Set myStream = CreateObject("ADODB.Stream")
  Set myIE = CreateObject("InternetExplorer.Application")
  Call MyXlChibaNpHttp(myLinks, myHTTP, myIE, myDoc, myStream, mySource)
  '
  Application.WindowState = xlMinimized
  Application.WindowState = xlNormal
  '
  mySource = Replace(mySource, "<h2 ", "<a ")
  mySource = Replace(mySource, "</h2>", "</a>")
  mySource = Replace(mySource, "<h3 ", "<a ")
  mySource = Replace(mySource, "</h3>", "</a>")
  myDoc.write mySource
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myTags = myDoc.getElementsByTagName("div")
  r = 1
  c = 0
  i = 0
  For Each myTag In myTags
    i = i + 1
    myStatusBar = "□千葉日報サイト 取り込み中:"
    myStatusBar = myStatusBar & " [" & ActiveSheet.Name & "] "
    myStatusBar = myStatusBar & i & "/" & myTags.Length & " "
    myStatusBar = myStatusBar & myTag.ID
    Application.StatusBar = myTitle & ": " & myStatusBar
    '
    Select Case myTag.ID
      Case "Ymd"
        Range("A1").Select
        Range("A1").Value = "千葉日報" & vbLf & myTag.innertext & vbLf
        With Selection
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlCenter
          .RowHeight = 70
        End With
        r = r + 1
      Case "wearther"
        myinnerText = myTag.innertext & vbLf
        ' myinnerText = ""
        ' Set mySubTags = myTag.getElementsByTagName("li")
        ' For Each mySubTag In mySubTags
        '   myinnerText = myinnerText & mySubTag.innertext & vbLf
        ' Next ' mySubTag
        ' myinnerText = Replace(myinnerText, "度 " & vbLf, "度" & vbLf & vbLf)
        Range("A16").Value = myinnerText
        ' *----*----*    *----*----*    *----*----*    *----*----*
      Case "ChangeSize"
        Set mySubTags = myTag.getElementsByTagName("a")
        For Each mySubTag In mySubTags
          If Len(mySubTag.Title) > 0 Then
            r = 2
            c = c + 1
            Cells(r, c).Value = mySubTag.innertext
          Else
            myHref = Replace(mySubTag.href, myIEblank & "../", myURL)
            myinnerText = mySubTag.innertext
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, c), Address:=myHref, TextToDisplay:=myinnerText
            '
            For Each v In mySheetArray
              If myinnerText = v Then
                myString = myLinks
                myString = myString & "," & myHref
                myLinks = myString
                Exit For
              End If
              DoEvents
            Next ' v
          End If
          r = r + 1
        Next ' mySubTag
        ' *----*----*    *----*----*    *----*----*    *----*----*
    End Select
    '
    DoEvents
  Next ' myTagDiv
  Columns("A:A").ColumnWidth = 1#
  Rows("1:100").RowHeight = 1#
  Columns("A:Z").EntireColumn.AutoFit
  Rows("1:100").EntireRow.AutoFit
  Columns("A:A").WrapText = True
  ActiveWindow.Zoom = 75
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem シートごとのの取り込み処理
  Application.ScreenUpdating = False
  myLinkArray = Split(myLinks, ",")
  myCounts = "0"
  For i = 1 To UBound(myLinkArray)
    Sheets(mySheetArray(i)).Activate
    myStatusBar = "□千葉日報サイト 取り込み中:"
    myStatusBar = myStatusBar & " [" & ActiveSheet.Name & "] "
    myStatusBar = myStatusBar & i & "/" & UBound(myLinkArray) & "頁 "
    Application.StatusBar = myTitle & ": " & myStatusBar
    '
    r = 1
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, 1), Address:=myLinkArray(i), TextToDisplay:=mySheetArray(i)
    myString = myLinkArray(i)
    Call MyXlChibaNpHttp(myString, myHTTP, myIE, myDoc, myStream, mySource)
    '
    Select Case ActiveSheet.Name
      Case "忙人寸語"
        myString = "<h2 title=" & Chr(34) & "忙人寸語" & Chr(34) & ">"
        mySource = Mid(mySource, InStr(mySource, myString))
      Case "フォトニュース"
        myString = "<h2>フォトニュース</h2>"
        mySource = Mid(mySource, InStr(mySource, myString))
      Case Else
        mySource = Replace(mySource, "<h2 ", "<a ")
        mySource = Replace(mySource, "</h2>", "</a>")
        mySource = Replace(mySource, "<div class=" & Chr(34), "<div id=" & Chr(34))
    End Select
    mySource = Replace(mySource, "title=" & Chr(34) & "一覧" & Chr(34), "")
    myDoc.write mySource
    '
    Select Case ActiveSheet.Name
      Case "忙人寸語"
        Set mySubTag1 = myDoc.getElementsByTagName("p")
        Set mySubTag2 = myDoc.getElementsByTagName("ul")
        r = 3
        For j = 1 To mySubTag1.Length
          myStatusBar = "□千葉日報サイト 取り込み中:"
          myStatusBar = myStatusBar & " [" & ActiveSheet.Name & "] "
          myStatusBar = myStatusBar & i & "/" & UBound(myLinkArray) & "頁 "
          myStatusBar = myStatusBar & j & "/" & mySubTag1.Length & "件 "
          Application.StatusBar = myTitle & ": " & myStatusBar
          '
          If mySubTag1(j - 1).className = "BoujinDays" Then
            Cells(r, 1) = mySubTag1(j - 1).innertext
            Cells(r, 2) = mySubTag2(j - 1).innertext & vbLf
            r = r + 1
          End If
          DoEvents
        Next ' j
        Columns("B:B").ColumnWidth = 1#
        Rows("3:100").RowHeight = 1#
        Columns("A:A").ColumnWidth = 30#
        Columns("B:B").ColumnWidth = 70#
        Columns("A:B").WrapText = True
        Rows("3:100").EntireRow.AutoFit
        ActiveWindow.Zoom = 75
        ' *----*----*    *----*----*    *----*----*    *----*----*
      Case "フォトニュース"
        Set myTags = myDoc.getElementsByTagName("div")
        r = 3
        j = 0
        For Each myTag In myTags
          j = j + 1
          myStatusBar = "□千葉日報サイト 取り込み中:"
          myStatusBar = myStatusBar & " [" & ActiveSheet.Name & "] "
          myStatusBar = myStatusBar & i & "/" & UBound(myLinkArray) & "頁 "
          myStatusBar = myStatusBar & j & "/" & myTags.Length & "件 "
          Application.StatusBar = myTitle & ": " & myStatusBar
          '
          Select Case myTag.className
            Case "PhotoArticle"
              myHref = Replace(myTag.Children(0).href, myIEblank, myURL)
              myinnerText = myTag.Children(1).innertext & vbLf
              myinnerText = myinnerText & myTag.Children(2).innertext & vbLf
              ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, 1), Address:=myHref, TextToDisplay:=myinnerText
              r = r + 1
          End Select
          DoEvents
        Next ' myTag
        Columns("B:B").ColumnWidth = 1#
        Rows("3:100").RowHeight = 1#
        Columns("A:B").ColumnWidth = 70#
        Rows("3:100").EntireRow.AutoFit
        ' *----*----*    *----*----*    *----*----*    *----*----*
      Case Else
        Set myTags = myDoc.getElementsByTagName("div")
        j = 0
        For Each myTag In myTags
          j = j + 1
          myStatusBar = "□千葉日報サイト 取り込み中:"
          myStatusBar = myStatusBar & " [" & ActiveSheet.Name & "] "
          myStatusBar = myStatusBar & i & "/" & UBound(myLinkArray) & "頁 "
          myStatusBar = myStatusBar & j & "/" & myTags.Length & "件 "
          Application.StatusBar = myTitle & ": " & myStatusBar
          '
          Select Case myTag.ID
            Case "news"
              Set mySubTags = myTag.getElementsByTagName("a")
              For Each mySubTag In mySubTags
                If Len(mySubTag.Title) > 0 Then
                  c = 1
                  r = r + 1
                  If mySubTag.innertext <> Cells(1, 1).Value Then
                    Cells(r, c).Value = mySubTag.innertext
                    r = r + 1
                  Else
                    Rem 1行目の見出しと同じものは表示しない。
                    Cells(r, c).Value = ""
                    r = r + 1
                  End If
                Else
                  If mySubTag.innertext <> "全文を読む" Then
                    myHref = Replace(mySubTag.href, myIEblank, myURL)
                    myinnerText = mySubTag.innertext
                    ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, c), Address:=myHref, TextToDisplay:=myinnerText
                    r = r + 1
                  End If
                End If
                DoEvents
              Next ' mySubTag
              Columns("A:Z").EntireColumn.AutoFit
              ' *----*----*    *----*----*    *----*----*    *----*----*
          End Select
          DoEvents
        Next ' myTag
    End Select
    myCounts = myCounts & "," & CStr(r - 1)
    '
    DoEvents
  Next ' i
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  myCountArray = Split(myCounts, ",")
  myMax = 0
  For i = 1 To UBound(myCountArray)
    myMax = myMax + CLng(myCountArray(i))
  Next ' i
  myCountArray(0) = CStr(myMax)
  Sheets(mySheetArray(0)).Activate
  '
  If CommandBars(myTitle).Controls(2).FaceId <> 220 Then GoTo MyXlChibaNpSubExit
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  c = 0
  For i = 1 To UBound(mySheetArray)
    Sheets(mySheetArray(i)).Activate
    '
    c = c + 1
    For r = 2 To myCountArray(i)
      c = c + 1
      myStatusBar = "□千葉日報サイト 本文 取り込み中 "
      myStatusBar = myStatusBar & c * 100 \ myMax & "% "
      myStatusBar = myStatusBar & "  [" & ActiveSheet.Name & "] "
      myStatusBar = myStatusBar & i & "/" & UBound(myLinkArray) & "頁 "
      myStatusBar = myStatusBar & r & "/" & myCountArray(i) & "行 "
      Application.StatusBar = myTitle & ": " & myStatusBar
      '
      Select Case ActiveSheet.Name
        Case "千葉日報サイトマップ"
          c = c + myCountArray(i) - 2
          Exit For
        Case "忙人寸語"
          c = c + myCountArray(i) - 2
          Exit For
        Case Else
          Select Case Cells(r, "A").Value
            Case "一覧"
              Rem
            Case Else
              If Cells(r, "A").Hyperlinks.Count > 0 Then
                myString = Cells(r, "A").Hyperlinks(1).Address
                Call MyXlChibaNpHttp(myString, myHTTP, myIE, myDoc, myStream, mySource)
                '
                mySource = Mid(mySource, InStr(mySource, "ChangeSize" & Chr(34) & ">") + 12)
                myString = "指定された記事はございません"
                If InStr(mySource, myString) > 0 Then
                  mySource = Replace(mySource, myString, "<p>" & myString & "</p>")
                  mySource = Left(mySource, InStrRev(mySource, "<hr") - 1)
                Else
                  mySource = Left(mySource, InStrRev(mySource, "<hr") - 1)
                  mySource = Left(mySource, InStrRev(mySource, "<hr") - 1)
                End If
                '
                mySource = Replace(mySource, "<h1 ", "<p ")
                mySource = Replace(mySource, "</h1>", "</p>")
                mySource = Replace(mySource, "<h2", "<p")
                mySource = Replace(mySource, "</h2>", "</p>")
                mySource = Replace(mySource, "<h3", "<p")
                mySource = Replace(mySource, "</h3>", "</p>")
                myDoc.write mySource
                '
                Set myTags = myDoc.getElementsByTagName("p")
                myString = ""
                For Each myTag In myTags
                  myString = myString & myTag.innertext & vbLf
                Next ' myTag
                Cells(r, "B").Value = myString
              End If
            End Select
      End Select
      '
      DoEvents
    Next ' r
    Columns("B:B").ColumnWidth = 1#
    Rows("3:100").RowHeight = 1#
    Columns("A:A").ColumnWidth = 30#
    Columns("B:B").ColumnWidth = 70#
    Columns("A:B").WrapText = True
    Rows("3:100").EntireRow.AutoFit
    ActiveWindow.Zoom = 75
    '
    DoEvents
  Next ' i
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyXlChibaNpSubExit:
  On Error Resume Next
  myIE.Quit
  Application.ScreenUpdating = True
  CommandBars(myTitle).Delete
  On Error GoTo 0
  Sheets(mySheetArray(0)).Activate
  '
  myStatusBar = "処理が終了しました。"
  Application.StatusBar = "MyXlChibaNp: " & myStatusBar
  Application.Speech.Speak myStatusBar, False
  '
  Set myHTTP = Nothing
  Set myIE = Nothing
  Set myDoc = Nothing
  Set myStream = Nothing
End Sub ' MyXlChibaNp *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlChibaNpHttp(myURL As String, myHTTP As Variant, myIE As Variant, myDoc As Variant, myStream As Variant, mySource As String)
  Dim myResponseBody As Variant
  '
  Call myHTTP.Open("GET", myURL, False)
  myHTTP.Send
  myResponseBody = myHTTP.responseBody
  '
  Const AdBinary = 1
  Const AdTypeText = 2
  myStream.Type = AdBinary
  myStream.Open
  myStream.write (myResponseBody)
  myStream.Position = 0
  myStream.Type = AdTypeText
  myStream.Charset = "EUC-JP" ' "iso-2022-jp"
  mySource = myStream.ReadText()
  ' myFile = "C:\Documents and Settings\User\My Documents\Zzz\Zzz.html"
  ' Call myStream.SaveToFile(myFile, 2)
  myStream.Close
  '
  With myIE
    .Navigate "about:blank"
    .Visible = False ' True
    Do While .Busy
      DoEvents
    Loop
    DoEvents
    Set myDoc = .Document
  End With
  '
  mySource = Replace(mySource, "<link ", "<!-- link ")
  mySource = Replace(mySource, "<script ", "<!-- script ")
  mySource = Replace(mySource, " src=", " Zzzsrc=")
  mySource = Replace(mySource, " SRC=", " Zzzsrc=")
 End Sub ' MyXlChibaNpHttp *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlChibaNpCmmdBar(myTitle As String)
  Dim myCmmdBar As CommandBar
  Dim myCtrlBttnIcon 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 myOnAction As String
  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 myCtrlBttnIcon = 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 & vbCrLf
  '
  With myCtrlBttnIcon
    .DescriptionText = "千葉日報サイト取り込み処理ポップアップメニュー"
    .Style = msoButtonIconAndWrapCaption
    .Caption = myMsg & "処理を実行しますか?"
    .TooltipText = "処理を実行しますか?"
    .FaceId = 1089
    .Parameter = "../sitemap/"
    myFaceId = .FaceId
    myOnAction = myTitle & "BttnMyValue" & " "
    myOnAction = myOnAction & Chr(&H22) & myTitle & ChrW(&H22) & ", " & "487"
    .OnAction = "'" & myOnAction & "'"
  End With
  '
  With myCtrlBttnDeTail
    .DescriptionText = "千葉日報サイト取り込み処理:[本文も取り込みする]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "本文も取り込みする"
    .TooltipText = "[本文]は取り込みしない。"
    .FaceId = 6963
    .OnAction = "'" & myTitle & "BttnMyDetail" & " " & Chr(&H22) & myTitle & ChrW(&H22) & ", " & .Index & "'"
  End With
  '
  With myCtrlBttnOk
    .DescriptionText = "千葉日報サイト取り込み処理:[実行]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "実行"
    .TooltipText = "処理をを実行します。"
    .FaceId = 964
    myOnAction = myTitle & "BttnMyValue" & " "
    myOnAction = myOnAction & Chr(&H22) & myTitle & ChrW(&H22) & ", " & .FaceId
    .OnAction = "'" & myOnAction & "'"
  End With
  '
  With myCtrlBttnCancel
    .DescriptionText = "千葉日報サイト取り込み処理:[キャンセル]ボタン"
    .Style = msoButtonIconAndCaption
    .Caption = "キャンセル" & Space(24)
    .TooltipText = "処理を中止します。"
    .FaceId = 330
    myOnAction = myTitle & "BttnMyValue" & " "
    myOnAction = myOnAction & Chr(&H22) & myTitle & ChrW(&H22) & ", " & .FaceId
    .OnAction = "'" & myOnAction & "'"
  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, 487 ' [チェックボックス]オン・オフ/[選択して下さい。]
        x = myCmmdBar.Left
        y = myCmmdBar.Top
        myCmmdBar.Controls(1).FaceId = myFaceId
      Case Else
        x = -1: y = -1
    End Select
  Loop
End Sub ' MyXlChibaNpCmmdBar *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlChibaNpBttnMyValue(myTitle As String, myValue As Long)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem コマンドボタンOnAction処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  CommandBars(myTitle).Controls(1).FaceId = myValue
End Sub ' MyXlChibaNpBttnMyValue *----*----*    *----*----*    *----*----*    *----*----*
  
Sub MyXlChibaNpBttnMyDetail(myTitle As String, myIndex As Long)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [ニュースの本文も取り込む]ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  With CommandBars(myTitle).Controls(myIndex)
    If .FaceId = 6963 Then
      .FaceId = 220
      .TooltipText = "[本文]も取り込みする。"
    Else
     .FaceId = 6963
     .TooltipText = "[本文]は取り込みしない。"
    End If
  End With
  CommandBars(myTitle).Controls(1).FaceId = CommandBars(myTitle).Controls(myIndex).FaceId
End Sub ' MyXlChibaNpBttnMyDetail *----*----*    *----*----*    *----*----*    *----*----*
inserted by FC2 system