Sub MyIeXlScs()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 山陰中央新報社 携帯サイト 読み込み処理
  Rem 作譜:Hitrock Camellia Shinopy
  Rem 言語:Excel VBA
  Rem 機能...
  Rem   山陰中央新報社の携帯サイトを読み込みし、
  Rem   その内容の一部をExcelシートに書き込みする。
  Rem 注記...
  Rem   MyIeXlScsを起動して使用。
  Rem   サイトのページ内容を取り損ねることがあるため、
  Rem   ページを読み込む時に、DoEvents関数で処理を一時停止させる。
  Rem   (これまでの試行により、前のページに戻る時は、不要と思われる。)
  Rem 履歴...
  Rem   第1版:2006/04/21:作成。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 参照設定する場合...
  Rem   Microsoft Internet Controls
  Rem   Microsoft HTML Object Library
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myIE As Variant ' InternetExplorer
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim myLink As Variant ' MSHTML.HTMLAnchorElement
  '
  Dim myURL As String
  Dim myHref As String
  Dim myArray As Variant
  Dim myGenre As Variant
  Dim myHead As String
  Dim myPage As String
  '
  Dim myStatusBar As String
  Dim i As Integer
  Dim myCount As Integer
  Dim myinnerText As String
  Dim myLead As String
  Dim myText As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem 山陰中央新報社の携帯サイト
  myURL = "http://www.sanin-chuo.co.jp/i/"
  '
  Application.CommandBars("Task Pane").Visible = False
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myIE = CreateObject("InternetExplorer.Application")
  '
  With myIE
    .Navigate myURL
    .Visible = False ' True
    Do While .Busy
      DoEvents
    Loop
    myStatusBar = "□山陰中央新報社 携帯サイト 読み込み開始"
    Application.StatusBar = "MyIeXlScs: " & myStatusBar
    DoEvents
    '
    Set myDoc = .Document
    myHead = myDoc.Title
  End With
  '
  Sheets(1).Activate
  myinnerText = myDoc.Body.innerText
  myinnerText = Left(myinnerText, InStr(myinnerText, vbCrLf & vbCrLf) - 2)
  myinnerText = Replace(myinnerText, vbCrLf, vbCr, 1, 1)
  myLead = Left(myinnerText, InStr(myinnerText, vbCr) - 1)
  myText = Mid(myinnerText, InStr(myinnerText, vbCr) + 1)
  Cells(1, "A").Value = myLead
  Cells(1, "B").Value = myText
  '
  Application.ScreenUpdating = False
  '
  myHead = "TOP"
  myHref = myURL
  Call MyIeXlScsPage(myHead, myHref, myIE)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myGenre = Split(myHead, ",")
  myArray = Split(myHref, ",")
  '
  If Worksheets.Count < UBound(myArray) + 1 Then
    myCount = UBound(myArray) + 1 - Worksheets.Count
    For i = 1 To myCount
      Worksheets.Add After:=Sheets(Worksheets.Count), Count:=1
    Next ' i
  End If
  '
  For i = 1 To UBound(myArray)
    With myIE
      .Navigate myArray(i)
      .Visible = False ' True
      Do While .Busy
        DoEvents
      Loop
      myStatusBar = "読み込み中:"
      myStatusBar = myStatusBar & myGenre(i) & "/" & "□ニュース:"
      myStatusBar = myStatusBar & i & "/" & UBound(myArray)
      Application.StatusBar = "MyIeXlScs: " & myStatusBar
      DoEvents
      '
      Sheets(i + 1).Activate
      myHead = myGenre(i)
      myPage = myArray(i)
      Call MyIeXlScsPage(myHead, myPage, myIE)
    End With
  Next ' i
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myIE.Visible = True
  myIE.Quit
  Application.ScreenUpdating = True
  Sheets(1).Activate
  '
  myStatusBar = "処理が終了しました。"
  Application.StatusBar = "MyIeXlScs: " & myStatusBar
  Application.Speech.Speak myStatusBar, False
  MsgBox myStatusBar, vbOKOnly + vbInformation, "MyIeXlScs" & ":終了"
  Application.StatusBar = ""
  '
  Set myIE = Nothing
  Set myDoc = Nothing
End Sub ' MyIeXlScs *----*----*    *----*----*    *----*----*    *----*----*

Sub MyIeXlScsPage(myHead As String, myHref As String, myIE As Variant)
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim myLink As Variant ' MSHTML.HTMLAnchorElement
  Dim myFlagTop As Boolean
  Dim myHrefTop As String
  '
  Set myDoc = myIE.Document
  '
  If myHead = "TOP" Then
    myFlagTop = False
    myHrefTop = myHref
    For Each myLink In myDoc.links
      Select Case myLink.innerText
        Case "山陰の出来事", "山陰の天気", "山陰経済ウイークリー", "主催行事"
          myFlagTop = True
          myHref = myHref & "," & myLink.href
          myHead = myHead & "," & myLink.innerText
        Case "コラム"
          myFlagTop = True
          myHrefTop = myHrefTop & "," & myLink.href
        Case "マイメニュー登録", "マイメニュー解除"
          Rem
        Case Else
          If myFlagTop = False Then
            myHrefTop = myHrefTop & "," & myLink.href
          End If
      End Select
    Next ' myLink
    Call MyIeXlScsBody("TOP", myHrefTop, myIE)
  Else
    For Each myLink In myDoc.links
      Select Case myLink.innerText
        Case "TOPへ", "次の記事へ", "記事一覧へ"
          Rem
        Case "0852-32-3415", "0120-49-2550"
          Rem
        Case Else
          myHref = myHref & "," & myLink.href
      End Select
    Next ' myLink
    Call MyIeXlScsBody(myHead, myHref, myIE)
  End If
  '
  Set myDoc = Nothing
End Sub ' MyIeXlScsPage *----*----*    *----*----*    *----*----*    *----*----*

Sub MyIeXlScsBody(myHead As String, myHref As Variant, myIE As Variant)
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim myArray As Variant
  Dim myStatusBar As String
  Dim i As Integer
  Dim myLine As Integer
  Dim myinnerText As String
  Dim myLead As String
  Dim myText As String
  Dim myDate As String
  '
  Set myDoc = myIE.Document
  myArray = Split(myHref, ",")
  '
  ActiveSheet.Name = myHead
  Columns("A:A").ColumnWidth = 30#
  Columns("B:B").ColumnWidth = 80#
  If myHead = "TOP" Then
    myLine = 2
  Else
    myLine = 1
  End If
  '
  For i = 1 To UBound(myArray)
    With myIE
      .Navigate myArray(i)
      .Visible = False ' True
      Do While .Busy
        DoEvents
      Loop
      myStatusBar = "●読み込み中:" & myHead & " " & i & "/" & UBound(myArray)
      Application.StatusBar = "MyIeXlScsBody: " & myStatusBar
      DoEvents
      '
      myinnerText = myDoc.Body.innerText
      Select Case True
        Case InStrRev(myinnerText, vbCrLf & "戻る") > 0
          myinnerText = Left(myinnerText, InStrRev(myinnerText, vbCrLf & "戻る") - 1)
        Case InStrRev(myinnerText, vbCrLf & "次の記事へ") > 0
          myinnerText = Left(myinnerText, InStrRev(myinnerText, vbCrLf & "次の記事へ") - 1)
        Case InStrRev(myinnerText, vbCrLf & "TOPへ") > 0
          myinnerText = Left(myinnerText, InStrRev(myinnerText, vbCrLf & "TOPへ") - 1)
      End Select
      '
      myinnerText = Replace(myinnerText, vbCrLf, vbCr, 1, 1)
      myinnerText = Replace(myinnerText, vbCrLf & vbCrLf & vbCrLf, "")
      myLead = " " & Left(myinnerText, InStr(myinnerText, vbCr) - 1)
      myText = Mid(myinnerText, InStr(myinnerText, vbCr) + 1)
      myText = Replace(myText, vbCrLf & vbCrLf, "")
      '
      Select Case myHead
        Case "TOP"
          myText = Replace(myText, "▼", vbLf)
        Case "山陰の天気"
          myText = Replace(myText, "<", " ")
          myText = Replace(myText, ">", vbLf)
          myText = Replace(myText, "◇", "")
          myText = Replace(myText, "。", "。" & vbLf)
          myText = Replace(myText, "晴れ一時雨", "晴れ 一時 雨")
          myText = Replace(myText, "曇り一時雨", "曇り 一時 雨")
          Columns("A:A").ColumnWidth = 15#
          Columns("B:B").ColumnWidth = 90#
        Case "主催行事"
          myText = Replace(myText, "◆", " ")
      End Select
      '
      Cells(myLine, "A").Value = myLead
      Cells(myLine, "B").Value = myText
      myLine = myLine + 1
    End With
  Next ' i
  '
  Columns("A:B").Select
  With Selection
    .Columns("A:A").Select
    .HorizontalAlignment = xlGeneral
    .VerticalAlignment = xlCenter
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
  End With
  Range("A1").Select
  '
  Set myDoc = Nothing
End Sub ' MyIeXlScsBody *----*----*    *----*----*    *----*----*    *----*----*
inserted by FC2 system