2017年01月22日

vbscript:IEを使って64bit環境でJSONをパース

vba/vbscriptでJSONをパースするにはScriptControlを使うのが手っ取り早くていいんだけど、64bit環境だとScriptControlが使えないから困る。何か代わりはないかと思ってたらIEが使えることに気づいた。
※vbscriptで試したけど64bit officeのvbaでも使えると思う。
って書いた後に"HtmlFile"なるものを使うとIEを起動しなくてもHTMLDocumentを使えるということを知ってもっと簡単になった。
Dim doc, jsn
'HTMLDocumentを取得
Set doc = CreateObject("HtmlFile")
'scriptタグを追加
doc.write "<script>document.JsonParse=function (s) {return eval('(' + s + ')');}</script>"
'パース関数でJSONオブジェクトを取得
Set jsn = doc.JsonParse("{a:1,b:2}")
WScript.Echo jsn.b
※ただパースは何も問題ないけど、不思議なことに JSON.stringify を使おうとしたらダメだった。(JSONオブジェクト自体がダメっぽい)

IEを使うパターンは折角書いてたし、こっちは JSON.stringify も使えるからこれはこれで残しとく。
Dim ie, n, jsn
'IEを起動
Set ie = CreateObject("InternetExplorer.Application")
'ie.Visible = True
'空画面を開く
ie.Navigate "about:blank"
Do While ie.Busy Or ie.ReadyState <> 4
WScript.Sleep 100
Loop
ie.document.body.innerHTML = "JsonParse用"
'JSONをパースする関数のscriptタグを動的に作成
Set n = ie.document.createElement("script")
n.Text = "document.JsonParse=function (s) {return eval('(' + s + ')');}"
ie.document.body.appendChild n
'パース関数でJSONオブジェクトを取得
Set jsn = ie.document.JsonParse("{a:1,b:2}")
WScript.Echo jsn.b
'IEを閉じる
ie.Quit
posted by 忘却の達人 at 09:39| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする

2014年12月16日

vba:砂時計の後始末を考えなくていいクラス

長めの処理でカーソルを砂時計(ブルーリング)にする時、たまにエラー時での後始末を忘れて砂時計のままになってることがあるんだけど、後始末を忘れても勝手にカーソルが元に戻るようにはできないものかと、虫のいいことを考えてたらふと思いついた。
クラスにしてコンストラクタで砂時計、デストラクタで元に戻せば、後始末を忘れても関数を抜ければ勝手にオブジェクトが破棄されてデストラクタが呼ばれるから勝手に元に戻ってくれるじゃないか。

Access用のクラス
クラス名:HourglassOn
Option Compare Database
Option Explicit

Private Sub Class_Initialize()
DoCmd.Hourglass True
End Sub

Private Sub Class_Terminate()
DoCmd.Hourglass False
End Sub
----------------------------------------------
'処理を行う関数
Sub HogeHoge()
On Error GoTo error_proc
With New HourglassOn 'End Withまで砂時計
あれやこれやの処理
End With
MsgBox "終わったぞっ", vbInformation
exit_proc:
Exit Sub
error_proc:
MsgBox Err.Description, vbCritical
Resume exit_proc
End Sub
-----------------------------------------------

この処理は通常は With〜End With の中だけ砂時計になる。但し例外エラーが発生してGoToで With文を抜けた場合は、End Withが実行されていないので砂時計のままとなる。が、それでも関数を抜ければオブジェクトが破棄されるのでちゃんと元のカーソルに戻ってくれるという訳。

砂時計以外でも描画停止・警告非表示などで同じようなやり方ができる。
posted by 忘却の達人 at 22:43| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする

2014年02月05日

vba:リボンの最小化

Office2010(2007以降?)で、リボンを最小化・元のサイズに戻す方法。
CommandBars.ExecuteMso "MinimizeRibbon"
このメソッドは最小化と元のサイズをトグルする。

最小化してるかどうかの判定。
CommandBars.GetPressedMso("MinimizeRibbon")
戻り値=True:最小化、False:元のサイズ

リボンを最小化・元のサイズに戻す関数
パラメータのMinimize=True:最小化、False:元のサイズ
Sub MinimizeRibbon(Optional Minimize As Boolean = True)
If Minimize Then
If Not CommandBars.GetPressedMso("MinimizeRibbon") Then
CommandBars.ExecuteMso "MinimizeRibbon"
End If
Else
If CommandBars.GetPressedMso("MinimizeRibbon") Then
CommandBars.ExecuteMso "MinimizeRibbon"
End If
End If
End Sub
posted by 忘却の達人 at 22:53| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする

2013年12月14日

vba:関数内の一部分のみのスコープを持つ変数

もちろんvbaの仕様は変えられないので「変数」では出来ないけど、オブジェクトを使えばWithステートメントの中だけ有効にすることが出来るので、そこに動的にプロパティを追加すればタイトルに近いことが出来る。
具体的にはJavascriptで同じ様なテーマで、連想配列をWithで使う以下の様な方法を書いてたサイトがあったので、これをvbaで実現することにした。
with ({a:0}) {
この中では a は有効。
}
withを抜けると a は参照不可。

そしてvbaで連想配列を返す関数は以下の通り。
Function TempDim(ByVal Dimension As String, Optional Parent As Object) As Object
'Dimension:変数宣言をカンマ区切りの文字列で行う。ex.)"TempNo,Name"
'Parent:ネストする場合、子のWith内では親の連想配列が参照できないので、
' パラメータとして渡す。
Dim sc As Object
Dim hash As Object
Dim i As Long
Dim v() As String
Set sc = CreateObject("ScriptControl")
sc.Language = "JScript"
sc.AddCode "function SetValue(hash, key, value) " & _
"{j=hash ? hash : {};j[key]=value;return j;}"
v = Split(Dimension, ",")
For i = LBound(v) To UBound(v)
Set hash = sc.CodeObject.SetValue(hash, v(i), Null)
Next i
Set hash = sc.CodeObject.SetValue(hash, "Me", hash)
If Not Parent Is Nothing Then
Set hash = sc.CodeObject.SetValue(hash, "Parent", Parent)
End If
Set TempDim = hash
End Function


そして以下の様に使用する。
宣言した名前はプロパティになるので、With内で頭にピリオドを付けて使用する。
With TempDim("i,j")
.i = 1
.j = 1
Do Until .i > 3
Debug.Print "親ループ i="; .i
Debug.Print "親ループ j="; .j
With TempDim("i", .Me) 'Meは自身を参照する
.i = 1
Do Until .i > 3
Debug.Print "子ループ i="; .i
.i = .i + 1
'Parentはパラメータで渡された親の連想配列
.Parent.j = .Parent.j + 1
Loop
End With
.i = .i + 1
Loop
End With

使用上の注意
  • For文のカウンターには使えない。
    For文のカウンターは変数でなければならず、この方法ではオブジェクトのプロパティとなるため使えない。
  • プロパティ名は大文字小文字が区別される。
    JScriptの機能で連想配列を実現してるのでJScriptの制限を受ける。VBエディタの変数名の自動修正機能に注意!
  • Variant型のみ
    連想配列に型が無いためそうなる。あと上の関数では初期値をNULLにしている。
posted by 忘却の達人 at 13:06| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする

2013年09月08日

VBA:IEの画面をキャプチャする手順

ソースは緑里庵のサイトを参照。
gooのトップページをキャプチャした画像。goo.bmp(9.26MB)
1.InternetExplorerオブジェクトを取得
IEを新規に開くか、すでに開いているIEを取得する。
2.IEの表示部分のWindowハンドルを取得
IEのWindowハンドルから子ウインドウをクラス名で辿る。
"Frame Tab" → "TabWindowClass" → "Shell DocObject View"
3.2で取得したWindowハンドルからBitmapを作成
2のWindowハンドルからDCを取得 → 互換DCを作成 → 互換DCの互換Bitmapを作成。作成するBitmapの幅と高さは、document.body.scrollWidth / scrollHeight
4.IEのDCから互換DCへ描画
ドキュメントが1画面に収まらない場合は、描画 → スクロール → 描画 …と繰り返す。
5.Bitmapを保存する
クリップボードにコピーする場合はBitmapハンドルを渡すだけ。
ファイルに作成する場合は、ヘッダーを作成しBitmapをバッファに取得して書き込む。
posted by 忘却の達人 at 09:49| Comment(5) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする

2011年04月08日

vba:住所⇔緯度・経度変換

vbaで住所から緯度・経度に変換する関数と、逆の緯度・経度から住所に変換する関数。
注意点:住所⇔緯度・経度変換にはGoogle Geocoding APIを利用しているので、このAPIの使用制限が適用される。しかも一括変換しようとすると、10件くらいまではすぐに変換してくれるけど、それ以降は1秒に1個くらいのペースでリクエストしないとエラー(status:"OVER_QUERY_LIMIT")になる。
vba独自の注意点:エディタが大文字小文字を勝手に変換することがあるが、連想配列のキーは大文字小文字を区別するので勝手に変換されるとエラーになる。例えば、以下のコードの「jsn.status」が「jsn.Status」になるとダメ。対処法は、一度「status」で変数宣言する。そうすればその後変数宣言を消しても小文字のままになる。CallByName関数を使う。CallByName(jsn, "status", vbGet)


Dim l As Variant
    l = AddressToLatLng("東京都新宿区西新宿2−8−1")
    MsgBox "lat:" & l(0) & vbCrLf & "lng:" & l(1)
    MsgBox LatLngToAddress(l(0), l(1))

'住所から緯度・経度に変換
'戻り値は配列で、(0)が緯度、(1)が経度。
Function AddressToLatLng(ByVal address As String) As Variant
Dim sc As Object
Dim jsn As Object
Dim result As Object
Dim http As Object
Dim url As String
    Set sc = CreateObject("ScriptControl")
    sc.Language = "JScript"
    sc.AddCode "function getLatLng(s) { return eval('(' + s + ')');}"

    url = "http://maps.google.com/maps/api/geocode/json?sensor=false&address=" & sc.CodeObject.encodeURI(address)

    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", url, False
    http.Send
    Set jsn = sc.CodeObject.getLatLng(http.ResponseText)
    If jsn.status = "OK" Then
        For Each result In jsn.results
            AddressToLatLng = Array(result.geometry.location.lat, result.geometry.location.lng)
            Exit For
        Next
    Else
        'エラー
        AddressToLatLng = Array(999, 999)
    End If

    Set jsn = Nothing
    Set sc = Nothing
End Function

'緯度・経度から住所に変換
Function LatLngToAddress(ByVal lat As Double, ByVal lng As Double) As String
Dim sc As Object
Dim jsn As Object
Dim result As Object
Dim http As Object
Dim url As String
Dim text As String
    Set sc = CreateObject("ScriptControl")
    sc.Language = "JScript"
    sc.AddCode "function getAddress(s) { return eval('(' + s + ')');}"

    url = "http://maps.google.com/maps/api/geocode/json?sensor=false&language=ja&latlng=" & lat & "," & lng

    Set http = CreateObject("MSXML2.XMLHTTP")
    http.Open "GET", url, False
    http.Send
    'ReplaceはShift_JISに無いハイフンが返されるためこれを全角ハイフンに変換
    Set jsn = sc.CodeObject.getAddress(Replace(http.ResponseText, ChrW(&H2212), "−"))
    If jsn.status = "OK" Then
        For Each result In jsn.results
            '「日本, 住所」の形で格納されてるので住所部分のみを取得
            LatLngToAddress = Split(result.formatted_address, ", ", 2)(1)
            Exit For
        Next
    Else
        'エラー
        LatLngToAddress = ""
    End If

    Set jsn = Nothing
    Set sc = Nothing
End Function
posted by 忘却の達人 at 21:10| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする

2011年03月19日

vba:正規表現

VBScript.RegExpオブジェクトを使ってvbaで正規表現を使う。但し、(…)でグループ化した部分を参照する、RegExp.$n は使えない。
「Microsoft VBScript Regular Expression 5.5」のライブラリ参照でアーリーバインドできる。
ex.)文字列からURLを抜き出す。
Dim re As Object
Dim rslt() As Object
Dim url As Object
Set re = CreateObject("VBScript.RegExp")
re.Pattern = "https?:\/\/([\w-]+\.)+[\w-]+(\/[\w-.\/?%&=]*)?"
re.IgnoreCase = True
re.Global = True
Set rslt = re.Execute("google:http://www.google.co.jp/,yahoo:http://www.yahoo.co.jp/")
For Each url In rslt
MsgBox url
Next
'rsltはコレクションなのでrslt(0)という記述もOK
posted by 忘却の達人 at 15:10| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする

2011年03月18日

vba:JavaScriptのコードを実行させる

ScriptControlオブジェクトを使うとvbaでJavaScriptのコードを実行させることができる。と言っても正確にはJScriptだけど。正規表現のマッチングやjsonデータを扱えるようになるのでいろいろ便利。
※64bit版OfficeだとScriptControlが使えないらしい。(32bit版OfficeならOSが64bitでもOK)

ex.文字列からyyyy/mm/ddを抜き出し、yyyymmddにして返す。

Dim sc As Object
Set sc = CreateObject("ScriptControl")
sc.Language = "JScript"
sc.AddCode "function extractDate(dt) { dt.match(/(\d{4})\/(\d{2})\/(\d{2})/); return RegExp.$1 + RegExp.$2 + RegExp.$3; }"
MsgBox sc.CodeObject.extractDate("今日の日付は2011/03/18です。")

※パラメータの無い関数だと罠があった。(Office2010で確認)
sc.AddCode "function noParam() { return 'やっほ〜'; }"
MsgBox sc.CodeObject.noParam() '←何故かエラーになる
MsgBox sc.CodeObject.noParam(0) '←適当にパラメータを渡すと動く
MsgBox CallByName(sc.CodeObject, "noParam", VbMethod) '←CallByNameを使うとパラメータが無くても動く
posted by 忘却の達人 at 00:51| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする

2010年09月03日

vba:月の何週目かを取得

vbaである日付がその月の何週目かを求める。

何週目 = (Day(対象日) + Weekday(対象日 - Day(対象日) + 1) - 2) \ 7 + 1
(対象日はDate型)
posted by 忘却の達人 at 21:21| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする

2009年04月16日

vba:クリップボードへの読み書き

クリップボードで読み書き行うためだけに↓のようなAPIごりごりのコードは、なんかイヤになったんで、COMオブジェクトを作ってスッキリさせた。
Set cls = CreateObject("clisou.Clipboard")
WScript.Echo cls.Text
Set cls = Nothing

こんな感じでちょー簡単。このCOMオブジェクトはこちらのページへ


vbaでクリップボードへのテキストの読み書きを行う関数。

Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function EmptyClipboard Lib "user32" () As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal dwBytes As Long) As Long
Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long

Public Const CF_TEXT = 1
Public Const GMEM_MOVEABLE = 2
Public Const MAXSIZE = 1048576

Function GetClipboardText()
Dim ClipHandle As Long
Dim ClipAddr As Long
Dim s As String
    If OpenClipboard(0) = 0 Then
        MsgBox "クリップボードが開きません"
        Exit Function
    End If
    ClipHandle = GetClipboardData(CF_TEXT)
    If IsNull(ClipHandle) Then
        MsgBox "クリップボードのハンドルが取得できません"
        GoTo exit_proc
    End If
    ClipAddr = GlobalLock(ClipHandle)
    If IsNull(ClipAddr) Then
        MsgBox "クリップボードメモリがロックできません"
        GoTo exit_proc
    End If
    s = String(lstrlen(ClipAddr) + 1, vbNullChar)
    lstrcpy s, ClipAddr
    GlobalUnlock ClipHandle
    GetClipboardText = Mid(s, 1, InStr(1, s, vbNullChar, 0) - 1)
exit_proc:
    CloseClipboard
End Function

Sub SetClipboardText(ByVal Text As String)
Dim ClipHandle As Long
Dim ClipAddr As Long
    If OpenClipboard(0) = 0 Then
        MsgBox "クリップボードが開きません"
        Exit Sub
    End If
    EmptyClipboard
    ClipHandle = GlobalAlloc(GMEM_MOVEABLE, LenB(StrConv(Text, vbFromUnicode)) + 1)
    If IsNull(ClipHandle) Then
        MsgBox "メモリが確保できません"
        GoTo exit_proc
    End If
    ClipAddr = GlobalLock(ClipHandle)
    If IsNull(ClipAddr) Then
        MsgBox "メモリがロックできません"
        GoTo exit_proc
    End If
    lstrcpy ClipAddr, Text
    GlobalUnlock ClipHandle
    SetClipboardData CF_TEXT, ClipAddr
    GlobalFree ClipHandle
exit_proc:
    CloseClipboard
End Sub
posted by 忘却の達人 at 07:23| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする

2008年01月19日

VBA:IEに表示されているページの内容を取得する

VBAでIEに表示されてるページを取得/設定する方法。
IEのWindowオブジェクトを取得すれば、Documentプロパティでページの内容を取得/設定できる。

Dim sh As Object
Dim ie As Object
Dim inp As Variant
Dim i As Long
Dim cnt As Long
Set sh = CreateObject("Shell.Application")
For Each ie In sh.Windows
If ie.FullName Like "*\IEXPLORE.EXE" Then
Exit For
End If
Next
If ie Is Nothing Then
Set sh = Nothing
Exit Sub
End If
cnt = ie.Document.all.tags("input").length
For i = 0 To cnt - 1
With ie.Document.all.tags("input")(i)
If .Name = "q" Then
Googleの検索文字 = .Value
Exit For
End If
End With
Next
Set ie = Nothing
Set sh = Nothing
posted by 忘却の達人 at 07:05| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする

2007年12月28日

VBA:http接続

"MSXML2.xmlhttp"オブジェクトを使うとVBAからhttpを利用できる。

Dim xmlhttp As Object
Set xmlhttp = CreateObject("MSXML2.xmlhttp")
xmlhttp.Open "GET", "http://アドレス/", False
xmlhttp.Send
Debug.Print xmlhttp.ResponseText
posted by 忘却の達人 at 04:10| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする

2007年12月22日

文字列を暗号化するVBA

CryptAPIを使って文字列を暗号化するVBA。

capicom.dllが必要でこのファイルがない環境は、マイクロソフトのサイトから
ダウンロードする必要がある。

' CAPICOM's constants.
Const CAPICOM_ENCRYPTION_ALGORITHM_RC2 = 0
Const CAPICOM_ENCRYPTION_ALGORITHM_RC4 = 1
Const CAPICOM_ENCRYPTION_ALGORITHM_DES = 2
Const CAPICOM_ENCRYPTION_ALGORITHM_3DES = 3
Const CAPICOM_ENCRYPTION_ALGORITHM_AES = 4 'Windows2000では何故か使えない

Const CAPICOM_ENCRYPTION_KEY_LENGTH_MAXIMUM = 0
Const CAPICOM_ENCRYPTION_KEY_LENGTH_40_BITS = 1
Const CAPICOM_ENCRYPTION_KEY_LENGTH_56_BITS = 2
Const CAPICOM_ENCRYPTION_KEY_LENGTH_128_BITS = 3
Const CAPICOM_ENCRYPTION_KEY_LENGTH_192_BITS = 4
Const CAPICOM_ENCRYPTION_KEY_LENGTH_256_BITS = 5

Sub Encrypt()
Dim Crypt As Object
Set Crypt = CreateObject("CAPICOM.EncryptedData")
Crypt.Algorithm.Name = CAPICOM_ENCRYPTION_ALGORITHM_3DES
Crypt.Algorithm.KeyLength = CAPICOM_ENCRYPTION_KEY_LENGTH_MAXIMUM
Crypt.SetSecret "パスワード"
Crypt.Content = InputBox("文字を入力してください")
Debug.Print Crypt.Encrypt
End Sub

Sub Decrypt()
Dim Crypt As Object
Set Crypt = CreateObject("CAPICOM.EncryptedData")
Crypt.Algorithm.Name = CAPICOM_ENCRYPTION_ALGORITHM_3DES
Crypt.Algorithm.KeyLength = CAPICOM_ENCRYPTION_KEY_LENGTH_MAXIMUM
Crypt.SetSecret "パスワード"
Crypt.Decrypt InputBox("暗号化された文字を入力してください")
Debug.Print Crypt.Content
End Sub
posted by 忘却の達人 at 11:31| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする

2006年11月10日

VBA:メソッドをコールバックする

コールバックさせるメソッド名を処理に渡して、CallByName関数でそのメソッドをコールバックする。
続きを読む
posted by 忘却の達人 at 08:32| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする

VBA:クラスにイベントを作る

クラス
イベントを宣言する。
RaiseEventステートメントでイベントを発行する。

フォーム
クラスをモジュール変数でWithEventsを指定して宣言する。
イベント関数は名前を"クラス変数名_イベント名"にする。
続きを読む
posted by 忘却の達人 at 08:16| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする

2006年11月07日

VBA:Compareパラメータの初期値

StrComp/InStr他の文字列比較をする関数のVbCompareMethod型のパラメータの初期値は、コード入力時に表示されるツールチップでは「vbBinaryCompare」になってるけど、実際はヘルプの記述にある通り「Option Compare」で指定された値となる。

Accessの場合、基本的に「vbTextCompare」になるので要注意。
posted by 忘却の達人 at 19:48| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする

2006年10月17日

VBA:配列の初期化

配列を初期化する。
Eraseステートメント
posted by 忘却の達人 at 04:40| Comment(0) | TrackBack(0) | vba | このブログの読者になる | 更新情報をチェックする

広告


この広告は60日以上更新がないブログに表示がされております。

以下のいずれかの方法で非表示にすることが可能です。

・記事の投稿、編集をおこなう
・マイブログの【設定】 > 【広告設定】 より、「60日間更新が無い場合」 の 「広告を表示しない」にチェックを入れて保存する。