non vorrei lavorare

昔はおもにプログラミングやガジェット系、今は?

VBScript三昧

最近VBScriptJavaScriptに凝ってます。(ってほどでもない気もしますが。。)
特にIEをコントロールしたり、mdbファイルを扱ってSQLを発行したりすることに

' Access_Tracker.vbs

Dim 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
Loop

Set 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
'Next

Set 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 strSqlStmt

Else
' 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
Loop

objADORS.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

関連記事

2年前の記事