VBScript三昧
最近VBScriptとJavaScriptに凝ってます。（ってほどでもない気もしますが。。）
特にIEをコントロールしたり、mdbファイルを扱ってSQLを発行したりすることに
' Access_Tracker.vbsDim items(10)
Dim match, matchCol' mdbファイルの指定
myMdbPath = "c:\work\Access_Tracker.mdb"' 解析CGIのURL
targetUrl = "http://hpcgi2.nifty.com/XXX/trackerBlog.cgi"Set Ie = WScript.CreateObject("InternetExplorer.Application")
Ie.Navigate targetUrl
Do While IE.Busy Or IE.ReadyState<>4
WScript.Sleep 100
LoopSet document=IE.document
document.loginForm.page.Value = "top"
' 最近のアクセスをチェック
document.loginForm.type(9).checked = true
document.loginForm.submit()Do While IE.Busy Or IE.ReadyState<>4
WScript.Sleep 100
Loop'デバッグ
'Set document=IE.document
'For Each item In document.All
'' 'WScript.Echo item.tagName
' If item.tagName = "HTML" Then
' WScript.Echo item.InnerHTML
'' WScript.Echo item.InnerText
' End If
'NextSet tables = Ie.document.getElementsByTagName("TABLE")
' 3番目のテーブルのみ対象
Set targetTable = tables(2)' mdb関連
Set objADO = CreateObject("ADODB.Connection")
objADO.Open "Driver={Microsoft Access Driver (*.mdb)}; DBQ="& myMdbPath &";"
For Each line In targetTable.getElementsByTagName("TR")
' 1アクセスの処理
Set tds = line.getElementsByTagName("TD")
' tdの要素を配列に入れる
index = 0
For Each td In tds
'WScript.Echo "(" & index & ")[" & td.innerHTML & "]"
If index = 0 Then
items(index) = td.innerText
Else
items(index) = td.innerHtml
End If
index = index + 1
Next
' 検索日付の取得
myDate = items(0)
' 曜日の部分を取り除く
Set regPattern = new RegExp
regPattern.Pattern = "(.*?) \(.*\) (.*)"
tmp = regPattern.Replace(myDate, "$1 " & "$2")
myDate = tmp
Set regPattern = Nothing
' キーワード解析
myQuery = items(6)
if Len(myQuery) > 0 Then
'WScript.Echo "[" & myQuery & "]"
' Google対応
Set regPattern = new RegExp
regPattern.Pattern = "A href=.*?google.*?/search.*?q=(.*?)\&"
Set matchCol = regPattern.Execute(myQuery)
If matchCol.Count > 0 Then
' Googleからのアクセスの場合
'WScript.Echo "[" & myQuery & "]"
Set match = matchCol(0)
tmpBuf = match.SubMatches(0)
regPattern.Pattern = "ie=Shift_JIS"
If regPattern.Test(tmpBuf) Then
' Shift JISの場合はそのまま
strSearch = tmpBuf
Else
With CreateObject("ScriptControl")
.Language = "JScript"
With .CodeObject
On Error Resume Next
strSearch = .decodeURI(tmpBuf)
End With
End With
End If
' +をスペースに変換
regPattern.Pattern = "\+"
regPattern.Global = true
tmp = regPattern.Replace(strSearch, " ")
strSearch = tmp
' %2Fを/に変換
regPattern.Pattern = "%2F"
regPattern.Global = true
tmp = regPattern.Replace(strSearch, "/")
strSearch = tmp
' " target=_blank>http://www.googleを削除する
regPattern.Pattern = "(.*)" & """" & " target=_blank>http://www.google.*"
tmp = regPattern.Replace(strSearch, "$1")
strSearch = tmp
'WScript.Echo "[" & tmpBuf & "]"
'WScript.Echo "<" & strSearch & ">@" & myDate
' mdbに登録
strSqlStmt = "INSERT INTO ACCESS_TRACKER (" & _
"search_date,search_key_phrase" & _
") VALUES (" & _
"'" & myDate & "'," & _
"'" & strSearch & "'" & _
")"
'WScript.Echo "strSqlStmt = " & strSqlStmt
' 重複エラーを事前のOn Error Resume Nextにより回避済み
objADO.Execute strSqlStmtElse
' Google以外
End If
Set regPattern = Nothing
End If
Next' 集計結果
On Error Goto 0
strSqlStmt = "select " & _
"search_key_phrase,count(*),sum(search_date) " & _
"from ACCESS_TRACKER " & _
"group by search_key_phrase " & _
"order by 2,3"Set objADORS = objADO.Execute(strSqlStmt)
Do While Not objADORS.EOF
buf = ""
For i = 0 to objADORS.Fields.Count -1
buf = buf & objADORS(i) & vbTab
Next
WScript.Echo buf
objADORS.MoveNext
LoopobjADORS.Close
Set objADORS = Nothing' mdbコネクションを切断
objADO.Close
Set objADO = Nothing
function URLDecodeHex(match, hex_digits, pos, source)
'URLDecodeHex = chr("&H" & hex_digits)
URLDecodeHex = "&H" & hex_digits
end function
最近のコメント