スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

検索急上昇 


本題に入る前に・・・
ブログ TOP の右上「全記事一覧」【緑色】・・・は気付かれてました?
サンプルファイルを置いているところで一覧表示しているものです。
記事本文はブログにしかないので、結局ここに戻ってくるのですが・・・
「インデックス(昇順)」「カテゴリ別」にわけてます。
(記事のタイトルから内容がわかり辛いのですが)

では本題に・・・ 副題:タグ解析?

最近、検索キーワード急上昇ランキング・・・とか、結構耳にします。
キーワードではないけど、
・ブログ内のどの記事が
・どんな感じで見られてる

FC2 でのアクセスランキングでは、
・リンク元
・人気ページ
・移動先
の3つを見る事が出来ます。以下の様な画面です。

kEnt197_1.jpg  kEnt197_2.jpg

ソース表示してみると、こんな感じです。

kEnt197_3.jpg

IE と連携すると情報は得られるようです。
(私が利用しているのは、IE9)

以下を Excel に記述して実行すると、ID 等区別して表示させる事が出来ます。
Public Sub ItemsShow()
  Dim o1 As Object, o2 As Object, o3 As Object
  Dim iRow As Long

  iRow = 1
  Cells.ClearContents
  Application.ScreenUpdating = False
  Set o1 = CreateObject("Shell.Application")
  Set o2 = o1.Windows(o1.Windows.Count - 1)
  For Each o3 In o2.Document.All
    With o3
      Cells(iRow, "A") = .ID
      Cells(iRow, "B") = .className
      Cells(iRow, "C") = .nodeName
      Cells(iRow, "D") = Left(.outerHTML, 60)
      Cells(iRow, "E") = Left(.innerText, 50)
    End With
    iRow = iRow + 1
  Next
  Open ActiveWorkbook.Path & "\a.txt" For Output As #1
  Print #1, o2.Document.body.outerHTML
  Close #1
  With ActiveSheet.UsedRange
    .HorizontalAlignment = xlLeft
    .EntireColumn.AutoFit
    .EntireRow.AutoFit
  End With
  Application.ScreenUpdating = True

  Set o2 = Nothing
  Set o1 = Nothing
End Sub

kEnt197_E1.jpg

※ IE を直接起動せずに、Shell.Application から IE を求めているので、
最後に表示したもの・・・・になるのですが、IE 操作後に
・エクスプローラを起動した・・・・ とかならエラーになります。
※ 最後に表示したものをシートに展開し、Body 部分をファイル「a.txt」に書き出します。
※ 最後に表示したものになるので、特定のURL・・・にはならないです。

さて、FC2 でのアクセスランキングへ辿り着くには・・・・
ログインして、チョンチョン・・・
パスワードは、VBA に書きたくないし、辿りが変わったら・・・
等々あって、上記のものをベースに・・・・
また、必要な部分 <TABLE ・・・</TABLE> 間だけソース表示から入手して・・・
これは、全部が全部 html 形式になっていなくても、それらしいものであれば部分的解釈を・・・

フォームを表示して、
kEnt197_F1.jpg

自動取得、もしくは部分的貼り付け・・・
kEnt197_F2.jpg

テーブルへ格納
kEnt197_T1.jpg

さて、取込はできたけど、これをどう料理していこうか・・・・
 
取込み用テーブルを「T収集一次」として用意
フィールドは、「an」「種類」「集計時間」「順位」「URL」「件」の6つ

種類用のテーブルとして「T種類」
種類
1 リンク元
2 人気ページ
3 移動先

kEnt197_T1.jpg

取込用フォーム「T取込」
(「F・・・」で作ったつもりが「T・・・」だった。問題は無いのでこのままで)

kEnt197_FD.jpg  kEnt197_F1.jpg

非連結のフォームになります。
「タブストップ:なし」のテキストボックス「txt1」
それを覆う様にラベル「lab1」
「自動取込」用のコマンドボタン「btn0」
「登録」用のコマンドボタン「btn1」

ラベル「lab1」の用途は、注意事項を表示しておいて、クリックされたら
・テキストボックス「txt1」にフォーカス移動
・自分を非表示に ※
Private Sub lab1_Click()
  Me.txt1.SetFocus
  Me.lab1.Visible = False
End Sub

※ 「txt1」にフォーカスが入ると「txt1」が前面に出てきます。
見栄え上「lab1」を非表示にしなくても良いのですが、次の操作でボタンをクリックすると「lab1」が前面に出てきます。

「txt1」の動きとしては、
・変更時に「登録」ボタンを表示
・更新後処理で、自分の状態で「登録」ボタンを表示/非表示
Private Sub txt1_Change()
  Me.btn1.Visible = True
End Sub

Private Sub txt1_AfterUpdate()
  Me.btn1.Visible = Not IsNull(Me.txt1)
End Sub

「自動取込」がクリックされたら、前述の方法で最後に表示されたURLの内容を入手

Private Sub btn0_Click()
  On Error Resume Next
  Call lab1_Click
  With CreateObject("Shell.Application")
    With .Windows(.Windows.Count - 1)
      Me.txt1 = .Document.body.outerHTML
    End With
  End With
  Me.btn1.Visible = True
End Sub


「登録」がクリックされたら・・・

1)最低限のチェックして
Private Sub btn1_Click()
  On Error Resume Next
  If (IsNull(Me.txt1)) Then Exit Sub
  Call fncBufAnalyse(Me.txt1)
  Me.txt1.SetFocus
End Sub

2)VBScript.RegExp を利用して解析
・文字列内の改行を排除して1行の文字列に・・・
  sBuf = sSrc
  sBuf = Replace(sBuf, vbCrLf, "")
  sBuf = Replace(sBuf, vbLf, "")
※ vbLf でも Replace しているのは、自動取込すると入り込んでいるみたいなので・・・

・ <TABLE ・・・・ </TABLE> 間の抽出
  With CreateObject("VBScript.RegExp")
    .Pattern = "<(TABLE)\b[^>]*>(.*?)</\1>"
    .IgnoreCase = True
    .Global = True
    If (Not .Test(sBuf)) Then Exit Sub
    For Each v1 In .Execute(sBuf)

ここで抽出されたものの中で、種類「リンク元」「人気ページ」「移動先」を切り分けていきます
FC2 のこのテーブル識別に、summary が使えそうです。
「<table cellspacing="0" summary="リンク元ランキング">」
「<table cellspacing="0" summary="人気ページランキング">」
「<table cellspacing="0" summary="移動先ランキング">」
この、summary を解釈し、テーブル「T種類」の「種類」を返すのを関数化(ベタな処理ですが)
(引数で渡すのは、上記の <table ・・・ > 部分)
Private Function fncGetSyu(sSrc As String) As Long
  Dim rs As New ADODB.Recordset
  Dim sAry() As String
  Dim v As Variant
  Dim sS As String

  rs.Open "T種類", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  fncGetSyu = 0
  For Each v In Split(sSrc, " ")
    sAry = Split(v, "=")
    If (UBound(sAry) > 0) Then
      If (sAry(0) = "summary") Then
        sS = Replace(sAry(1), """", "")
        Do While (Not rs.EOF)
          If (sS Like rs("何") & "*") Then
            fncGetSyu = rs("種類")
            Exit Do
          End If
          rs.MoveNext
        Loop
        Exit For
      End If
    End If
  Next
  rs.Close
End Function

3)集計時間の抽出
・集計時間は TABLE 内の TFOOT 部分にあるようなので、RegExp の Pattern を変えながら絞り込みます。
        .Pattern = "<(TFOOT)\b[^>]*>(.*?)"
        For Each v2 In .Execute(v1)
          .Pattern = "<(TD)\b[^>]*>(.*?)</\1>"
          For Each v3 In .Execute(v2)
            .Pattern = "<.*?>"
            sS = Trim(.Replace(v3, ""))
            If (sS Like "集計時間*") Then
              dt = CDate(Mid(sS, InStr(sS, ":") + 1))
            End If
          Next
        Next

4)順位、URL、件の抽出
・これらは、TABLE 内の TBODY 部分にあるようなので・・・
 辿りついたら、テーブルに登録するものは用意できているので、順次テーブルに書き込んでいきます。
        rs.Open CTBL, CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic
        .Pattern = "<(TBODY)\b[^>]*>(.*?)</\1>"
        For Each v2 In .Execute(v1)
          .Pattern = "<(TR)\b[^>]*>(.*?)</\1>"
          For Each v3 In .Execute(v2)
            iCnt = 0
            rs.AddNew
            rs("種類") = iSyu
            rs("集計時間") = dt
            .Pattern = "<(TD)\b[^>]*>(.*?)</\1>"
            For Each v4 In .Execute(v3)
              .Pattern = "<.*?>"
              sS = Trim(.Replace(v4, ""))
              iCnt = iCnt + 1
              Select Case iCnt
                Case 1: rs("順位") = CLng(sS)
                Case 2: rs("URL") = sS
                Case 3: rs("件") = CLng(sS)
              End Select
            Next
            rs.Update
          Next
        Next
        rs.Close

※ .Pattern = "<.*?>" でタグ部分を削除していますが、DOM ? とかでは innerText で済む様ですけど・・・

取込んだデータがあれば、テーブル「T収集一次」を表示して、フォームを閉じる・・・・
VBA 全記述は以下になります。
Private Sub lab1_Click()
  Me.txt1.SetFocus
  Me.lab1.Visible = False
End Sub

Private Sub txt1_Change()
  Me.btn1.Visible = True
End Sub

Private Sub txt1_AfterUpdate()
  Me.btn1.Visible = Not IsNull(Me.txt1)
End Sub

Private Sub btn0_Click()
  On Error Resume Next
  Call lab1_Click
  With CreateObject("Shell.Application")
    With .Windows(.Windows.Count - 1)
      Me.txt1 = .Document.body.outerHTML
    End With
  End With
  Me.btn1.Visible = True
End Sub

Private Sub btn1_Click()
  On Error Resume Next
  If (IsNull(Me.txt1)) Then Exit Sub
  Call fncBufAnalyse(Me.txt1)
  Me.txt1.SetFocus
End Sub

Private Function fncGetSyu(sSrc As String) As Long
  Dim rs As New ADODB.Recordset
  Dim sAry() As String
  Dim v As Variant
  Dim sS As String

  rs.Open "T種類", CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  fncGetSyu = 0
  For Each v In Split(sSrc, " ")
    sAry = Split(v, "=")
    If (UBound(sAry) > 0) Then
      If (sAry(0) = "summary") Then
        sS = Replace(sAry(1), """", "")
        Do While (Not rs.EOF)
          If (sS Like rs("何") & "*") Then
            fncGetSyu = rs("種類")
            Exit Do
          End If
          rs.MoveNext
        Loop
        Exit For
      End If
    End If
  Next
  rs.Close
End Function

Private Sub fncBufAnalyse(sSrc As String)
  Dim rs As New ADODB.Recordset
  Dim sBuf As String
  Dim sS As String
  Dim v1 As Variant, v2 As Variant, v3 As Variant, v4 As Variant
  Dim iCnt As Long
  Dim dt As Date, iSyu As Long
  Const CTBL As String = "T収集一次"

  sBuf = sSrc
  sBuf = Replace(sBuf, vbCrLf, "")
  sBuf = Replace(sBuf, vbLf, "")
  dt = Now()

  With CreateObject("VBScript.RegExp")
    .Pattern = "<(TABLE)\b[^>]*>(.*?)</\1>"
    .IgnoreCase = True
    .Global = True
    If (Not .Test(sBuf)) Then Exit Sub
    CurrentProject.Connection.Execute "DELETE * FROM " & CTBL & ";"
    For Each v1 In .Execute(sBuf)
      iSyu = fncGetSyu(Left(v1, InStr(v1, ">")))
      If (iSyu > 0) Then
        .Pattern = "<(TFOOT)\b[^>]*>(.*?)</\1>"
        For Each v2 In .Execute(v1)
          .Pattern = "<(TD)\b[^>]*>(.*?)</\1>"
          For Each v3 In .Execute(v2)
            .Pattern = "<.*?>"
            sS = Trim(.Replace(v3, ""))
            If (sS Like "集計時間*") Then
              dt = CDate(Mid(sS, InStr(sS, ":") + 1))
            End If
          Next
        Next

        rs.Open CTBL, CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic
        .Pattern = "<(TBODY)\b[^>]*>(.*?)</\1>"
        For Each v2 In .Execute(v1)
          .Pattern = "<(TR)\b[^>]*>(.*?)</\1>"
          For Each v3 In .Execute(v2)
            iCnt = 0
            rs.AddNew
            rs("種類") = iSyu
            rs("集計時間") = dt
            .Pattern = "<(TD)\b[^>]*>(.*?)</\1>"
            For Each v4 In .Execute(v3)
              .Pattern = "<.*?>"
              sS = Trim(.Replace(v4, ""))
              iCnt = iCnt + 1
              Select Case iCnt
                Case 1: rs("順位") = CLng(sS)
                Case 2: rs("URL") = sS
                Case 3: rs("件") = CLng(sS)
              End Select
            Next
            rs.Update
          Next
        Next
        rs.Close
      End If
    Next
    If (DCount("*", CTBL) > 0) Then
      DoCmd.OpenTable CTBL
      DoCmd.Close acForm, Me.Name, acSaveNo
    End If
  End With
End Sub

 
まぁ、これでゴリゴリ・ベタで処理してみたんで DOM ? とかの関数はイメージして使えそう・・・かな

サンプルファイルはここまでですけど・・・・ って、先もまだないんですが
一次取込は出来ましたが、どういった蓄積していくのが良いんでしょうかね・・・・
見るだけ・・・・ 解析するだけ・・・
どの様な解析をしたいか・・・ によって、本テーブルの持ち方を決めれば良いか・・・
同じデータは一箇所に・・・ が基本と思いますが、
見るだけ用途であれば、それ用に加工したテーブルが複数あっても良いと思います。

クエリを噛ませれば同じ・・・・ 本当にそうなのかな?

まぁ、今のままでも1つのテーブルにドンドン放り込んで
・種類/期間抽出して、
・URLでグループ化
・Max(件) - Min(件) を降順で表示とか・・・・ 急上昇っていうのはこんな感じ???
あっ、そうか・・・ 急降下っていうのも考えないと・・・???
Access で、グラフってやったこと無いけど・・・・折れ線とかで表示してみても良いかも・・・

フォームで入力してみて、動きを確かめてみてください・・・といっても、
FC2 ユーザさん以外は確認しようがないと思いますので、私の実際のアクセスランキング
・kEnt197.txt - 2014/5/18 の部分的ソース
・kEnt197_1.txt - 2014/6/17 の部分的ソース
・kEnt197_2.txt - 2014/7/5 の部分的ソース
の3ファイルが同梱されています。
(余談で、1/1 にクリアしているので今年の情報となってます)

う~~ん・・・ 
私のこのブログ・・・
広告表示されるようになると、移動先の「FC2カウンター」が多くなるけど・・・
何かあるのかなぁ???・・・

サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt197_2000.zipkEnt197_2003.zipkEnt197_2007.zip
 サイズ 29,63330,47232,025
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化


※ そうそう、IE を使って情報収集する際、相手側サーバの負荷とか考えている・・・???
まっ、上記は自分で辿って、表示した後にチョコっと・・・ 負荷的には同じですよね・・・
関連記事

2014/07/05

Category: やってみる

TB: --  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。