Sub MyXlScNp()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 山陰中央新報サイト[新着情報]ページ取り込み処理
  Rem 言語：Excel VBA
  Rem 機能...
  Rem   山陰中央新報サイトの[新着情報]ページを、[外部データの取り込み]とHttpRequestで取り込む。
  Rem 注記...
  Rem   1. 不具合：<新着ニュース[山陰]>の本文は、取り込みに失敗することがある。
  Rem   2. MyXlScNpを起動し、ポップアップメニューをクリックして、処理を開始する。
  Rem      サイト上の本文のタグが不定のため、C列にタグ内容を標示する。
  Rem   3. なぜか、IEの「Visible = False」が機能しないので、
  Rem      ExcelのWindowStateの操作で対処。
  Rem 履歴...
  Rem   第01版：2007/02/18 作成。
  Rem   第02版：2007/03/02 OnActionの指定を変更
  Rem   第03版：2007/05/06：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.AnchorElement
  Dim myStream As Variant '
  Dim myResponseBody As Variant ' Byte()
  Dim mySource As String
  '
  Dim myMax As Long
  Dim myText As String
  Dim myString As String
  '
  Dim myURL As String
  Dim myHref As String
  Dim myStatusBar As String
  '
  Dim i  As Long
  Dim myAns  As Long
  Dim myCbox As Boolean
  Dim myTitle As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myTitle = "MyXlScNp"
  '
  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 = "MyXlScNpBttnMyDetail"
    .OnAction = "'" & myTitle & "BttnMyDetail" & " " & Chr(&H22) & myTitle & ChrW(&H22) & "'"
    ' .OnAction = "'MyXlScNpBttnMBttnMyDetail ""MyXlScNp""'"
  End With
  '
  With myCtrlBttnOk
    .DescriptionText = "山陰中央新報サイト[新着情報]ページ取り込み処理：[OK]ボタン"
    .BeginGroup = True
    .Style = msoButtonIconAndCaption
    .Caption = "OK"
    .TooltipText = "処理をを実行します。"
    .FaceId = 459
    .OnAction = "'" & myTitle & "BttnMyValue" & " " & Chr(&H22) & myTitle & ChrW(&H22) & ", " & "459" & "'"
    ' .OnAction = "MyXlScNpBttnMyValue(myTile, 459)"
  End With
  '
  With myCtrlBttnCancel
    .DescriptionText = "山陰中央新報サイト[新着情報]ページ取り込み処理：[キャンセル]ボタン"
    .Style = msoButtonIconAndCaption
    .Caption = "キャンセル" & Space(24)
    .TooltipText = "処理を中止します。"
    .FaceId = 330
    .OnAction = "'" & myTitle & "BttnMyValue" & " " & Chr(&H22) & myTitle & ChrW(&H22) & ", " & "330" & "'"
    ' .OnAction = "MyXlScNpBttnMyValue(myTile, 330)"
  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 = True
  Else
    myCbox = False
  End If
  '
  On Error Resume Next
  myCmmdBar.Delete
  On Error GoTo 0
  '
  If myAns = vbCancel Then Exit Sub
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  ActiveSheet.Range("A1").Select
  Application.CommandBars("Task Pane").Visible = False
  ActiveSheet.Name = "新着ニュース[山陰地域]"
  '
  myMax = Worksheets.Count - ActiveSheet.Index + 1
  If myMax < 3 Then
    myMax = 3 - myMax
    For i = 1 To myMax
      Worksheets.Add After:=Sheets(Worksheets.Count), Count:=1
    Next ' i
    Sheets("新着ニュース[山陰地域]").Activate
  End If
  '
  myURL = "http://www.sanin-chuo.co.jp/"
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myStatusBar = "□山陰中央新報サイト[新着情報]ページ 取り込み開始"
  Application.StatusBar = myTitle & ": " & myStatusBar
  '
  With ActiveSheet.QueryTables.Add(Connection:="FINDER;" & myURL & "modules/information", Destination:=Range("A2"))
    .WebSelectionType = xlSpecifiedTables
    .WebFormatting = xlWebFormattingAll
    .WebTables = "18,20"
    .Refresh BackgroundQuery:=False
  End With
  Range("A1").Select
  Application.ScreenUpdating = False
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  ActiveCell.SpecialCells(xlLastCell).Select
  myMax = ActiveCell.Row
  Range("A1").Select
  For i = 2 To myMax
    If Range("A" & i).Value = "" Then
      Range("A" & i).Select
      Exit For
    End If
  Next ' i
  Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
  Selection.Copy
  ActiveSheet.Next.Select
  Range("A1").Select
  ActiveSheet.Name = "新着ニュース[国内・海外]"
  Selection.PasteSpecial Paste:=xlPasteColumnWidths
  ActiveSheet.Paste
  Range("A1").Select
  '
  Sheets("新着ニュース[山陰地域]").Activate
  Selection.ClearContents
  Range("A1").Select
  '
  ActiveSheet.Next.Select
  ActiveSheet.Next.Select
  Range("A1").Select
  '
  myStatusBar = "□山陰中央新報サイト[新着情報]ページ 取り込み開始"
  Application.StatusBar = myTitle & ": " & myStatusBar
  Application.ScreenUpdating = True
  '
  Set myIE = CreateObject("InternetExplorer.Application")
  With myIE
    .Navigate "http://www.sanin-chuo.co.jp/uploads/shinchaku.html"
    .Visible = False ' True
    Do While .Busy
      DoEvents
    Loop
    DoEvents
    Set myDoc = .Document
  End With
  Application.WindowState = xlMinimized
  Application.WindowState = xlNormal
  '
  ActiveSheet.Name = "新着情報"
  Application.ScreenUpdating = False
  i = 2
  For Each myLink In myDoc.Links
    Cells(i, 1).Select
    ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=myLink.href, TextToDisplay:=myLink.innerText
    i = i + 1
  Next ' myLink
  Columns("A:A").EntireColumn.AutoFit
  Range("A1").Select
  Application.ScreenUpdating = True
  myIE.Visible = False ' True
  myIE.Quit
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Sheets("新着ニュース[山陰地域]").Activate
  ActiveWindow.Zoom = 50
  '
  If myCbox = True Then
    ActiveSheet.UsedRange.Select
    ActiveCell.SpecialCells(xlLastCell).Select
    myMax = ActiveCell.Row
    For i = myMax To 1 Step -1
      If Range("A" & i).Value <> "" Then
        Exit For
      End If
    Next ' i
    myMax = i
    '
    For i = 2 To myMax
      Range("A" & i).Select
      If Selection.Hyperlinks.Count <> 0 Then
        Range("B" & i).Value = Selection.Hyperlinks(1).Address
      End If
    Next ' i
    '
    Set myIE = CreateObject("InternetExplorer.Application")
    DoEvents
    Range("B1").Select
    For i = 2 To myMax
      If Range("B" & i).Value <> "" Then
        Range("B" & i).Select
        Call MyXlScNpBody(Range("B" & i).Value, myIE)
      End If
      myStatusBar = "□山陰中央新報サイト[新着情報]ページ 本文 取り込み中 "
      myStatusBar = myStatusBar & i * 100 \ myMax & "%　"
      myStatusBar = myStatusBar & i & "/" & myMax & "行　"
      Application.StatusBar = myTitle & ": " & myStatusBar
      DoEvents
    Next ' i
    myIE.Visible = False ' True
    myIE.Quit
  End If
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Range("A1").Select
  Application.ScreenUpdating = True
  myStatusBar = "処理が終了しました。"
  Application.StatusBar = myTitle & ": " & myStatusBar & Now()
  Application.Speech.Speak myStatusBar, False
  Set myIE = Nothing
  Set myDoc = Nothing
End Sub ' MyXlScNp *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlScNpBody(myURL As String, myIE As Variant)
  Dim myHTTP As Variant ' IXMLHTTPRequest
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim myResponseBody As Variant ' Byte()
  Dim myStream As Variant ' Stream
  Dim mySubTags As Variant ' DispHTMLElementCollection
  Dim mySubTag As Variant ' HTMLHeaderElement
  '
  Dim myText As String
  Dim myValue As String
  Dim myStatusBar As String
  '
  Dim myRegExp As Variant ' VBScript_RegExp_55.RegExp
  Dim myMatches As Variant ' MatchCollection
  Dim myMatch As Variant ' Match
  Dim myPttn As String
  Dim myString As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myHTTP = CreateObject("MSXML2.XMLHTTP") ' ("Microsoft.XMLHTTP")
  With myIE
    .Navigate "about:blank"
    .Visible = False  ' True
    Do While .Busy
      DoEvents
    Loop
    DoEvents
    Set myDoc = .Document
  End With
  DoEvents: DoEvents: DoEvents: DoEvents: DoEvents
  DoEvents: DoEvents: DoEvents: DoEvents: DoEvents
  '
  Call myHTTP.Open("GET", myURL, False)
  On Error Resume Next
  myHTTP.Send
  If Err.Number <> 0 Then
    Range("C" & ActiveCell.Row).Value = "Send Error"
    Exit Sub
  End If
  On Error GoTo 0
  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, "MyXlKanaloco"
    GoTo MyXlScNpBodySubExit
  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, "MyXlKanaloco"
    GoTo MyXlScNpBodySubExit
  End If
  myResponseBody = myHTTP.responseBody
  '
  Const AdBinary = 1
  Const AdTypeText = 2
  Set myStream = CreateObject("ADODB.Stream")
  myStream.Type = AdBinary
  myStream.Open
  myStream.write (myResponseBody)
  myStream.Position = 0
  myStream.Type = AdTypeText
  myStream.Charset = "EUC-JP"
  myText = myStream.ReadText()
  ' myFile = "C:\Documents and Settings\User\My Documents\Zzz\Zzz.html"
  ' Call myStream.SaveToFile(myFile, 2)
  myStream.Close
  '
  myText = Replace(myText, "<link ", "<!-- link ")
  myText = Replace(myText, "<title>", " --> <title>")
  myText = Replace(myText, "<img ", "<!-- img ")
  myText = Replace(myText, "<script ", "<!-- script ")
  myText = Replace(myText, " src=", " Zzzsrc=")
  myText = Replace(myText, " SRC=", " Zzzsrc=")
  myText = Replace(myText, "<BR><BR>", "<BR>")
  '
  Set myRegExp = CreateObject("VBScript.RegExp") ' New VBScript_RegExp_55.RegExp
  myPttn = "<p>(\s|\S)*</p>" ' "<p>(.*?)</p>" '
  With myRegExp
    .Pattern = myPttn ' パターンを指定
    .IgnoreCase = False ' 大文字小文字を区別する。
    .Global = True ' 文字列全体を検索
  End With
  '
  Set myMatches = myRegExp.Execute(myText)
  myString = ""
  If myMatches.Count <> 0 Then
    For Each myMatch In myMatches
      myString = myString & myMatch.Value
    Next ' myMatch
  Else
    myText = Replace(myText, vbCrLf, "")
    myText = Replace(myText, vbTab, "")
    '
    If InStr(myText, "<td valign=" & ChrW(&H22) & "top" & ChrW(&H22) & ">") > 0 Then
      Range("C" & ActiveCell.Row).Value = "Tag <td>"
      myText = Mid(myText, InStrRev(myText, "<td valign=" & ChrW(&H22) & "top" & ChrW(&H22) & ">"))
      myText = Left(myText, InStr(myText, "</td>") + 5)
      myString = "<p>" & myText & "</p>"
    Else
      Range("C" & ActiveCell.Row).Value = "Tag </table>"
      myPttn = "(</table>|</TABLE>)(.*?)<BR></font>" ' "(</table>|</TABLE>)(\s|\S)+<BR></font>"
      '
      With myRegExp
        .Pattern = myPttn ' パターンを指定
        .IgnoreCase = False ' 大文字小文字を区別する。
        .Global = True ' 文字列全体を検索
      End With
      '
      Set myMatches = myRegExp.Execute(myText)
      If myMatches.Count <> 0 Then
        For Each myMatch In myMatches
          myString = myString & myMatch.Value
        Next ' myMatch
        myString = Replace(myString, "</TABLE>", "</table>")
        myString = Replace(myString, "</table>", "<p>", InStrRev(myString, "</table>"), 1)
        myString = Replace(myString, "<BR></font>", "</p>")
      End If
    End If
  End If
  '
  myDoc.write myString
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myValue = ""
  With ActiveCell
    .ColumnWidth = 120
    .VerticalAlignment = xlTop
    .WrapText = True
  End With
  '
  Set mySubTags = myDoc.getElementsByTagName("p")
  If Not mySubTags Is Nothing Then
    For Each mySubTag In mySubTags
      myValue = myValue & mySubTag.innerText & vbLf
      DoEvents
    Next ' mySubTag
  End If
  ActiveCell.Value = myValue
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyXlScNpBodySubExit:
  Set myDoc = Nothing
  Set myHTTP = Nothing
End Sub ' MyXlScNpBody *----*----*    *----*----*    *----*----*    *----*----*
  
Sub MyXlScNpBttnMyValue(myTitle As String, myValue As Long)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem コマンドボタンOnAction処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  CommandBars(myTitle).Controls(1).FaceId = myValue
End Sub ' MyXlScNpBttnMyValue *----*----*    *----*----*    *----*----*    *----*----*
  
Sub MyXlScNpBttnMyDetail(myTitle As String)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem [ニュースの本文も取り込む]ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  With CommandBars(myTitle).Controls(2)
    If .FaceId = 6963 Then
      .FaceId = 220
      .TooltipText = "ニュースの本文も取り込む。"
    Else
     .FaceId = 6963
     .TooltipText = "ニュースの本文は取り込まない。"
    End If
  End With
End Sub ' MyXlScNpBttnMyDetail *----*----*    *----*----*    *----*----*    *----*----*