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 *----*----* *----*----* *----*----* *----*----*