2011/10/09

iPhone4S販売決定

ついにsoftbankとauからiPhone4Sが発表になりました。
最初はsoftbankを解約してauの携帯をiPhone4Sにしようかと思いましたが、softbankの発表を聞いて現状のままauは携帯、softbankはiPhoneで行くことに決定。
3GSユーザなので、さっそく予約。 家族会議の結果、追加料金が出なければ機種変OKとのことなので16gbを予約しました。

初日はシステムダウンするほどの申し込みだったようです。
14日に受け取りできるんだろうか・・・。

楽しみですね。

softbankのiPhoneページ
http://mb.softbank.jp/mb/iphone/

auのiPhoneページ
http://www.au.kddi.com/iphone/
Posted at 11:19 in iPhone | WriteBacks (0) | Edit
Tagged as: , ,

2011/07/24

地デジ化

本日12時、完全地デジ化となりました。
Posted at 12:26 in n/a | WriteBacks (0) | Edit

2011/07/13

sqlite3のDLLを作る。

諦めていたわけではないのですが・・・。
mingw32を使うと割とスムーズにできたので・・・。

まずは、sqlite3ダウンロードページからソースが一つにまとめられた amalgamation 版をダウンロードします。
で、コマンドプロンプトでダウンロードしたフォルダへ移動して


>c:\MinGW\bin\gcc -mrtd -c -O2 -DSQLITE_THREADSAFE=1 -DSQLITE_API="__declspec(dllexport)" sqlite3.c

でコンパイルして

>c:\MinGW\bin\gcc -shared -o sqlite3.dll sqlite3.o -Wl,--add-stdcall-alias,--kill-at,--out-def=sqlite3.def

でDLLが出来上がります。

この方法だと__stdcallで出来上がるそうなので、vbから呼び出しokです。
(-mrtdを渡すことで既定の規約を__stdcallへ変更できる)

sqlite使って遊びましょう。
Posted at 00:49 in program | WriteBacks (1) | Edit
Tagged as: , , ,

2011/06/18

vbaでhmac その2

前に書いたけど、今回は一発で行けます。
'http://msdn.microsoft.com/en-us/library/aa382379(v=vs.85).aspx 参考

Option Explicit

Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" _
  (ByRef phProv As Long, ByVal pszContainer As String, ByVal pszProvider As String, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32.dll" _
  (ByVal hProv As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32.dll" _
  (ByVal hProv As Long, ByVal algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, ByRef phHash As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32.dll" _
  (ByVal hHash As Long) As Long
Private Declare Function CryptHashData Lib "advapi32.dll" _
  (ByVal hHash As Long, ByRef pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptGetHashParam Lib "advapi32.dll" _
  (ByVal hHash As Long, ByVal dwParam As Long, ByRef pbData As Any, ByRef pdwDataLen As Long, ByVal dwFlags As Integer) As Long
Private Declare Function CryptDeriveKey Lib "advapi32.dll" _
  (ByVal hProv As Long, ByVal algid As Long, ByVal hBaseData As Long, ByVal dwFlags As Long, ByRef phKey As Long) As Long
Private Declare Function CryptDestroyKey Lib "advapi32.dll" _
  (ByVal hKey As Long) As Long
Private Declare Function CryptSetHashParam Lib "advapi32.dll" _
  (ByVal hHash As Long, ByVal dwParam As Long, ByRef pbData As Any, ByVal dwFlags As Integer) As Long
Private Declare Function CryptImportKey Lib "advapi32.dll" _
  (ByVal hProv As Long, ByRef pbData As Any, ByVal dwDataLen As Long, ByVal hPubKey As Long, ByVal dwFlags As Long, ByRef phKey As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
  (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" _
  (Destination As Any, ByVal Length As Long)
Private Const CRYPT_VERIFYCONTEXT As Long = &HF0000000
Private Const MS_DEF_PROV As String = "Microsoft Base Cryptographic Provider v1.0"
Private Const ALG_TYPE_ANY As Long = 0
Private Const ALG_CLASS_HASH As Long = 32768
Private Const ALG_TYPE_BLOCK As Long = 1536
Private Const ALG_SID_SHA As Long = 4
Private Const ALG_SID_SHA1 As Long = ALG_SID_SHA
Private Const ALG_CLASS_DATA_ENCRYPT As Long = 24576
Private Const ALG_TYPE_STREAM As Long = 2048
Private Const ALG_SID_RC4 As Long = 1
Private Const ALG_SID_RC2 As Long = 2
Private Const ALG_SID_HMAC As Long = 9
Private Const CALG_SHA As Long = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA
Private Const CALG_SHA1 As Long = CALG_SHA
Private Const CALG_RC2 As Long = ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_BLOCK Or ALG_SID_RC2
Private Const CALG_RC4 As Long = ALG_CLASS_DATA_ENCRYPT Or ALG_TYPE_STREAM Or ALG_SID_RC4
Private Const CALG_HMAC As Long = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_HMAC
Private Const HP_HMAC_INFO = &H5
Private Const HP_HASHVAL As Long = 2
Private Const PROV_RSA_FULL As Long = 1
Private Const PLAINTEXTKEYBLOB As Long = 8
Private Const CUR_BLOB_VERSION As Long = 2
Private Const CRYPT_IPSEC_HMAC_KEY = &H100
Private Type HMAC_Info
  HashAlgid As Long
  pbInnerString As Byte
  cbInnerString As Long
  pbOuterString As Byte
  cbOuterString As Long
End Type
Private Type BLOBHEADER
  bType As Byte
  bVersion As Byte
  reserved As Integer
  aiKeyAlg As Long
End Type
Private Type key_blob
  hdr As BLOBHEADER
  len As Long
  key(1024) As Byte '// TODO might want to dynamically allocate this, Should Be Fine though
End Type

Private Function hmac(ByVal strKey As String, ByVal strData As String) As String
  Dim bytKey() As Byte
  Dim bytData() As Byte
  Dim ret As Long
  Dim lngProv As Long       'コンテナオブジェクト
  Dim lngHash As Long       'ハッシュオブジェクト
  Dim lngHmacHash As Long   'ハッシュオブジェクト
  Dim lngHashSize As Long   'ハッシュサイズ
  Dim lngKey As Long        'キーオブジェクト
  Dim bytBuff() As Byte     'ハッシュが格納されるエリア
  Dim strHex As String      '16進数文字列
  Dim i As Long
  Dim HmacInfo As HMAC_Info
  Dim keyblob As key_blob
  Dim key_len As Long
  
  hmac = ""
  strHex = ""
  
  'バイト配列へ
  bytKey = StrConv(strKey, vbFromUnicode)
  bytData = StrConv(strData, vbFromUnicode)

  '1024バイトチェック
  key_len = UBound(bytKey) + 1
  If key_len > 1024 Then
    hmac = ""
    Exit Function
  End If

  'キーコンテナの作成
  ret = CryptAcquireContext(lngProv, vbNullString, vbNullString, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT)
  If ret = False Then
    GoTo ExitHandler
  End If

'  '鍵作り
'  ret = CryptDeriveKey(lngProv, CALG_RC2, lngHash, 0, lngKey)
'  If ret = False Then
'    Call CryptDestroyKey(lngKey)
'    GoTo ExitHandler
'  End If

  '// key creation based on
  '// http://mirror.leaseweb.com/NetBSD/NetBSD-release-5-0/src/dist/wpa/src/crypto/crypto_cryptoapi.c
  keyblob.hdr.bType = PLAINTEXTKEYBLOB
  keyblob.hdr.bVersion = CUR_BLOB_VERSION
  keyblob.hdr.reserved = 0
  '/*
  '* Note: RC2 is not really used, but that can be used to
  '* import HMAC keys of up to 16 byte long.
  '* CRYPT_IPSEC_HMAC_KEY flag for CryptImportKey() is needed to
  '* be able to import longer keys (HMAC-SHA1 uses 20-byte key).
  '*/
  keyblob.hdr.aiKeyAlg = CALG_RC2
  keyblob.len = key_len
  Call ZeroMemory(keyblob.key(0), key_len)
  Call CopyMemory(keyblob.key(0), bytKey(0), key_len)
  ret = CryptImportKey(lngProv, keyblob, 12 + key_len, 0, CRYPT_IPSEC_HMAC_KEY, lngKey)
  If ret = False Then
    GoTo ExitHandler
  End If
  
  'ハッシュオブジェクトの作成
  ret = CryptCreateHash(lngProv, CALG_HMAC, lngKey, 0, lngHmacHash)
  If ret = False Then
    GoTo ExitHandler
  End If
  
  'パラメータセット
  HmacInfo.HashAlgid = CALG_SHA1
  ret = CryptSetHashParam(lngHmacHash, HP_HMAC_INFO, HmacInfo, 0)
  If ret = False Then
    GoTo ExitHandler
  End If

  'ハッシュデータを作る
  ret = CryptHashData(lngHmacHash, bytData(0), UBound(bytData) + 1, 0)
  If ret = False Then
    GoTo ExitHandler
  End If

  '必要なサイズを取得
  ret = CryptGetHashParam(lngHmacHash, HP_HASHVAL, ByVal 0, lngHashSize, 0)
  If ret = False Then
    GoTo ExitHandler
  End If
  
  'ハッシュを取り出す
  ReDim bytBuff(lngHashSize - 1)
  For i = 0 To UBound(bytBuff)
    bytBuff(i) = 0
  Next
  ret = CryptGetHashParam(lngHmacHash, HP_HASHVAL, bytBuff(0), lngHashSize, 0)
  If ret = False Then
    GoTo ExitHandler
  End If

  'HEX文字列へ
  For i = 0 To UBound(bytBuff)
    strHex = strHex & Right("0" & LCase(Hex(bytBuff(i))), 2)
  Next
  
ExitHandler:
  If (lngHmacHash) Then
    CryptDestroyHash (lngHmacHash)
  End If
  If (lngKey) Then
    Call CryptDestroyKey(lngKey)
  End If
  If (lngHash) Then
    Call CryptDestroyHash(lngHash)
  End If
  If (lngProv) Then
    Call CryptReleaseContext(lngProv, 0)
  End If
  hmac = strHex
End Function

Private Sub hmac_test()
  Debug.Print hmac("key", "data")
End Sub

win32apiを使っているので、こっちが早いと思います。
Posted at 02:19 in program::vba | WriteBacks (11) | Edit
Tagged as: , ,

2011/06/09

vbaでHTMLダイアログ

便利だけどあまりwebに見つからないので。
インターネットでもローカルファイルでも行けます。
Option Explicit

'HRESULT CreateURLMoniker(
'    IMoniker *pMkCtx,
'    LPCWSTR szURL, //ワイド文字
'    IMoniker **ppmk
');
'
'HRESULT ShowHTMLDialog(
'    HWND hwndParent,
'    IMoniker *pMk,
'    VARIANT *pvarArgIn,
'    LPWSTR pchOptions, //ワイド文字
'    VARIANT *pvarArgOut
');


Private Declare Function CreateURLMoniker Lib "urlmon.dll" _
  (ByVal pMkCtx As Long, _
  ByVal szURL As Long, _
  ByRef ppmk As Long) As Long
Private Declare Function ShowHTMLDialog Lib "mshtml.dll" _
  (ByVal hwndParent As Long, _
  ByVal pMk As Long, _
  ByVal pvarArgIn As Long, _
  ByVal pchOptions As Long, _
  ByVal pvarArgOut As Long) As Long
Private Const S_OK = 0
Private Const E_OUTOFMEMORY = &H8007000E
Private Const MK_E_SYNTAX = &H800401E4

'pchOptions
'dialogHeight:sHeight
'dialogLeft:sXPos
'dialogTop:sYPos
'dialogWidth:sWidth
'center:{ yes | no | 1 | 0 | on | off }
'dialogHide:{ yes | no | 1 | 0 | on | off }
'edge:{ sunken | raised }
'resizable:{ yes | no | 1 | 0 | on | off }
'scroll:{ yes | no | 1 | 0 | on | off }
'status:{ yes | no | 1 | 0 | on | off }
'unadorned:{ yes | no | 1 | 0 | on | off }

Sub test()
  Dim moniker As Long
  Dim szURL As String
  Dim ret As Long
  
  Const options = "help:no; status:no; dialogWidth:460px; dialogHeight=320px"
  szURL = "http://www.google.co.jp"
  'szURL = "file://c:/test.htm"
  ret = CreateURLMoniker(0, StrPtr(szURL), moniker)
   
  If ret = S_OK Then
    
    ret = ShowHTMLDialog(0, moniker, 0, StrPtr(options), 0)
    
    If ret = S_OK Then
      MsgBox "成功"
    Else
      MsgBox "失敗"
    End If
  
  End If
   
End Sub

便利!
Posted at 23:43 in program::vba | WriteBacks (1) | Edit
Tagged as: ,

2011/05/12

コメントスパム対策

コメントスパム対策のため下記ページを参考にして対応してみた。
これで減らなければ、別の手を考える。

interpolate_fancyプラグインの使い方

手軽にblosxomのflavourシステムを強化することが出来るようになるinterpolate_fancyプラグインについて今さら書いてみようかとか。本当に今さらすぎて笑えない。今さらとはいえ、blosxomのflavourシステムを強化するプラグインとしてはこれくらいしか選択肢はないので書いておいても損ではないはず。
まず、interpolate_fancy-tricksmetaプラグインを導入してフレーバーに
<?!$meta::nowriteback>
  <form ...>
  ...
  </form>
</?>

を記入、記事に

meta-nowriteback: 1
を記入するだけ。
簡単!
Posted at 00:51 in blosxom | WriteBacks (0) | Edit
Tagged as:

2011/04/30

VBAでのURLエンコード

前の記事でコメントをいただきましたので、自分ならこうするだろうということで。

Function UrlEncode(strTarget As String) As String
  Dim obj As Object
  Dim s As String

  If Len(strTarget) = 0 Then Exit Function
  
  Set obj = CreateObject("ScriptControl")
  obj.Language = "JScript"
  s = obj.CodeObject.encodeURIComponent(strTarget)
  'エンコードされないので文字の対策
  s = Replace(s, "(", "%28") '(
  s = Replace(s, ")", "%29") ')
  s = Replace(s, "!", "%21") '!
  UrlEncode = s
End Function

手抜きまくってます・・・。
Posted at 01:42 in program::vba | WriteBacks (23) | Edit
Tagged as: ,

2011/02/16

VB/VBAでTwitter

なんとかVBAで出来ないかといろいろ調べて、何とかできました。

このページを参考にしました。

Twitter API を OAuth で認証するスクリプトを 0 から書いてみた - trial and error

どうも。昨日もちょっと twitter に触れましたが、今日も twitter ねたです。

前の post で、チラッと触れた OAuth 認証 (O認証認証みたいでこわい) を使ってみたくなり、自分で 0 から書いて見ました。

windows2000、IE6、ms-office2000以降なら動くと思います。

Private Declare Function CryptBinaryToString Lib "crypt32.dll" Alias "CryptBinaryToStringA" _
    (ByRef pbBinary As Any, _
     ByVal cbBinary As Long, _
     ByVal dwFlags As Long, _
     ByVal pszString As String, _
     ByRef pcchString As Long _
     ) As Long
Private Const CRYPT_STRING_BASE64  As Long = 1

Private Const consumer_key = "consumer-key"
Private Const consumer_secret = "consumer-securet"

Private Const reqt_url = "http://twitter.com/oauth/request_token"
Private Const auth_url = "http://twitter.com/oauth/authorize"
Private Const acct_url = "http://twitter.com/oauth/access_token"
Private Const post_url = "https://twitter.com/statuses/update.xml"
Private Const frtl_url = "http://twitter.com/statuses/friends_timeline.xml"

'Proxyを使う場合はユーザ名:パスワードで指定
'Private Const proxy_user = ""

Sub test()
  Dim XHR As New MSXML2.XMLHTTP 'IEのxmlHttpRequestと同じ(クッキー・プロキシも同じ設定を使う)
  Dim param As Scripting.Dictionary
  Dim reqdata As String
  Dim digest As String
  Dim buf() As Byte
  Dim res As String
  Dim XMLDOM As MSXML2.DOMDocument
  Dim proxy_auth As String
  Dim otoken As String, otoken_secret As String
  Dim atoken As String, atoken_secret As String
  Dim pin As String


  If Len(proxy_user) > 0 Then
    proxy_auth = EncodeBase64(StrConv(proxy_user, vbFromUnicode))
  End If
  
  Set param = CreateObject("Scripting.Dictionary")
  '共通
  param("oauth_consumer_key") = consumer_key
  param("oauth_signature_method") = "HMAC-SHA1"
  param("oauth_version") = "1.0"
  
  '毎回必要
  param("oauth_timestamp") = CStr(DateDiff("s", #1/1/1970#, Now()))
  param("oauth_nonce") = param("oauth_timestamp") * 333333 '適当にかぶらない数字
  reqdata = "GET&" & UrlEncode(reqt_url) & "&" & UrlEncode(UrlParse(param))
  digest = hmac(consumer_secret & "&", reqdata)
  buf = StrToBynary(digest)
  param("oauth_signature") = Trim(EncodeBase64(buf))
  
  Call XHR.Open("GET", reqt_url & "?" & UrlParse(param), False)
  If Len(proxy_user) > 0 Then
    Call XHR.SetRequestHeader("Proxy-Authorization", "Basic " & proxy_auth)
  End If
  XHR.Send
  Debug.Print "リクエストトークンをリクエスト レスポンスコード:"; XHR.status
  
  'authトークン(一時的に使う為)
  otoken = GetOAuthToken(XHR.ResponseText)
  otoken_secret = GetOAuthToken_secret(XHR.ResponseText)
  
  'PIN取得の為IEを起動(引数にauthトークンを指定)
  Shell "c:\Program Files\Internet Explorer\iexplore.exe " & auth_url & "?oauth_token=" & otoken
  pin = InputBox("pinを入力")
  If pin = "" Then Exit Sub
  
  '作り直し
  param.Remove ("oauth_signature")
  param("oauth_timestamp") = CStr(DateDiff("s", #1/1/1970#, Now()))
  param("oauth_nonce") = param("oauth_timestamp") * 333333
  param("oauth_verifier") = pin '今回だけ(PINコード)
  param("oauth_token") = otoken '今回だけ(authトークン)
  reqdata = "GET&" & UrlEncode(acct_url) & "&" & UrlEncode(UrlParse(param))
  digest = hmac(consumer_secret & "&" & otoken_secret, reqdata)
  buf = StrToBynary(digest)
  param("oauth_signature") = Trim(EncodeBase64(buf))
  
  Call XHR.Open("GET", acct_url & "?" & UrlParse(param), False)
  If Len(proxy_user) > 0 Then
    Call XHR.SetRequestHeader("Proxy-Authorization", "Basic " & proxy_auth)
  End If
  XHR.Send
  Debug.Print "アクセルトークンをリクエスト レスポンスコード:"; XHR.status

  'アクセストークン(今のところ期限が無いので恒久的。次回はいきなり指定してもOK)
  atoken = GetOAuthToken(XHR.ResponseText)
  atoken_secret = GetOAuthToken_secret(XHR.ResponseText)

  '作り直し
  param.Remove ("oauth_verifier")
  param.Remove ("oauth_signature")
  param("oauth_timestamp") = CStr(DateDiff("s", #1/1/1970#, Now()))
  param("oauth_nonce") = param("oauth_timestamp") * 333333
  param("oauth_token") = atoken
  param("count") = "50"
  reqdata = "GET&" & UrlEncode(frtl_url) & "&" & UrlEncode(UrlParse(param))
  digest = hmac(consumer_secret & "&" & atoken_secret, reqdata)
  buf = StrToBynary(digest)
  param("oauth_signature") = Trim(EncodeBase64(buf))
  
  Call XHR.Open("GET", frtl_url & "?" & UrlParse(param), False)
  If Len(proxy_user) > 0 Then
    Call XHR.SetRequestHeader("Proxy-Authorization", "Basic " & proxy_auth)
  End If
  XHR.Send
  Debug.Print "APIアクセス レスポンスコード:"; XHR.status
  
  Dim status As MSXML2.IXMLDOMSelection
  Dim texts As MSXML2.IXMLDOMElement
  Dim i As Long
  Set XMLDOM = XHR.responseXML
  Set status = XMLDOM.getElementsByTagName("status")
  For Each texts In status
      Debug.Print ConvertCreateTime(texts.selectSingleNode("created_at").FirstChild.NodeValue);
      Debug.Print texts.selectSingleNode("user/screen_name").FirstChild.NodeValue; ": ";
      Debug.Print texts.selectSingleNode("text").FirstChild.NodeValue
  Next
    
End Sub

'wsh機能を使う(JScript)
Private Function UrlEncode(strTarget As String) As String
  Dim obj As Object
  If Len(strTarget) = 0 Then Exit Function
  Set obj = CreateObject("ScriptControl")
  obj.Language = "JScript"
  UrlEncode = obj.CodeObject.encodeURIComponent(strTarget)
End Function

'win32API(恐らくwin2000から動く)
Function EncodeBase64(bytTarget() As Byte) As String
  Dim strBase64 As String
  Dim lngBase64_Len As Long
  Dim ret As Long
  '必要な容量を計算
  ret = CryptBinaryToString(bytTarget(0), UBound(bytTarget) + 1, CRYPT_STRING_BASE64, vbNullString, lngBase64_Len)
  If ret Then
      strBase64 = Space(lngBase64_Len)
      ret = CryptBinaryToString(bytTarget(0), UBound(bytTarget) + 1, CRYPT_STRING_BASE64, strBase64, Len(strBase64))
  End If
  EncodeBase64 = Mid(strBase64, 1, lngBase64_Len - 3)
End Function

'keyをソートして配列を返す
Private Function KeySort(dic As Scripting.Dictionary) As Variant
  Dim i As Long, j As Long
  Dim varTemp As Variant
  Dim varData As Variant
  
  If dic Is Nothing And dic.Count = 0 Then
    Exit Function
  End If
  
  varData = dic.Keys
  
  '総当りでソート(バブルソート)
  For i = 0 To dic.Count - 1
    For j = i + 1 To dic.Count - 1
      '比較
      If varData(i) > varData(j) Then
        varTemp = varData(i)
        varData(i) = varData(j)
        varData(j) = varTemp
      End If
    Next
  Next
  
  KeySort = varData
End Function

'dictionaryオブジェクトのキーをソートしてkey1=value1&key2=valu2...の文字列を返す
Private Function UrlParse(dictionary_object As Scripting.Dictionary) As String
  Dim strReqData As String
  Dim d As Variant
  Dim i As Long
  On Error Resume Next
  d = KeySort(dictionary_object)
  For i = 0 To UBound(d)
    strReqData = strReqData & "&" & CStr(d(i)) & "=" & dictionary_object(d(i))
  Next
  If Err.Number = 0 Then
    UrlParse = Mid(strReqData, 2)
  Else
    UrlParse = ""
  End If
  On Error GoTo 0
End Function

'暗号化
Private Function hmac(ByVal key As String, ByVal data As String) As String
  Dim i As Integer
  Dim hash As String
  Dim key_byte() As Byte
  Dim key_len As Long
  Dim data_len As Long
  Dim ipad(63) As Byte
  Dim opad(63) As Byte
  Dim key_hash() As Byte
  Dim data_hash As String

  If key = "" And data = "" Then Exit Function

  key_len = Len(key)

  key_byte = StrConv(key, vbFromUnicode)
  If key_len > 64 Then
      key_hash = StrToBynary(CreateSHA1Hash(key_byte))
      key_len = 20
  Else
      key_hash = key_byte
  End If
  
  ReDim Preserve key_hash(63)
  For i = key_len To 63
    key_hash(i) = 0
  Next

  For i = 0 To 63
    ipad(i) = 0
    opad(i) = 0
  Next

  For i = 0 To 63
    ipad(i) = key_hash(i) Xor &H36
    opad(i) = key_hash(i) Xor &H5C
  Next

  data_hash = CreateSHA1Hash(CStr(ipad) & StrConv(data, vbFromUnicode))

  hash = CreateSHA1Hash(CStr(opad) & CStr(StrToBynary(data_hash)))

  hmac = hash
End Function

'バイト文字列からバイト配列を返す
Private Function StrToBynary(strHexString As String) As Byte()
  Dim buf() As Byte
  Dim i As Long
  
  ReDim Preserve buf(Len(CStr(strHexString)) \ 2 - 1)
  For i = 0 To Len(CStr(strHexString)) \ 2 - 1
    buf(i) = CByte("&h" & Mid(CStr(strHexString), i * 2 + 1, 2))
  Next
  StrToBynary = buf
End Function

'TwitterAPIの作成日から日付型の変数を返す
Private Function ConvertCreateTime(strCreated_at As String) As Date
  ConvertCreateTime = DateValue(Mid(strCreated_at, 5, 6) & Right(strCreated_at, 5)) + TimeValue(Mid(strCreated_at, 11, 9)) + TimeValue("09:00")
End Function

'TwitterAPIのレスポンスからTokenを抜き出す
Private Function GetOAuthToken(strTarget As String) As String
  Dim s, a, v
  s = Split(strTarget, "&")
  For Each a In s
    v = Split(a, "=")
    If v(0) = "oauth_token" Then
      GetOAuthToken = v(1)
      Exit Function
    End If
  Next
End Function

'TwitterAPIのレスポンスからsecretを抜き出す
Private Function GetOAuthToken_secret(strTarget As String) As String
  Dim s, a, v
  s = Split(strTarget, "&")
  For Each a In s
    v = Split(a, "=")
    If v(0) = "oauth_token_secret" Then
      GetOAuthToken_secret = v(1)
      Exit Function
    End If
  Next
End Function


hmacは前のエントリーのモジュールが必要です。
Posted at 00:38 in program::vba | WriteBacks (7) | Edit
Tagged as: , , ,

2011/02/15

Scripting.Dictionaryオブジェクトのソート

あまり必要ありませんが、何かに使えるかもしれないのでメモ。

バリアント配列の初期化に誤りがあったので修正

Private Sub DicSort(ByRef dic As Scripting.Dictionary)
  Dim i As Long, j As Long
  Dim d As Variant
  Dim varTemp As Variant
  Dim varData() As Variant
  
  If dic Is Nothing And dic.Count = 0 Then
    Exit Sub
  End If
  
  'バリアント二次元配列
  ReDim varData(dic.Count - 1 , 1)
  i = 0
  For Each d In dic
    varData(i, 0) = d
    varData(i, 1) = dic(d)
    i = i + 1
  Next
  
  '総当りでソート(バブルソート)
  For i = 0 To dic.Count - 1
    For j = i + 1 To dic.Count - 1
      '比較
      If varData(i, 0) > varData(j, 0) Then
        '次の配列の値が小さい場合は入替
        varTemp = Array(varData(i, 0), varData(i, 1))
        varData(i, 0) = varData(j, 0)
        varData(i, 1) = varData(j, 1)
        varData(j, 0) = varTemp(0)
        varData(j, 1) = varTemp(1)
      End If
    Next
  Next
  
  dic.RemoveAll
  
  For i = 0 To UBound(varData)
    dic(varData(i, 0)) = varData(i, 1)
  Next
End Sub

エラーチェックはしていません。
Posted at 23:51 in program::vba | WriteBacks (4) | Edit
Tagged as: ,

2011/02/12

vbaでhmac

とある事情からvbaのみでhmacができないか調べました。
で、できました。
スーの道具箱/気まぐれ日記/2007-03-08

VBでハッシュを求める *
MD5をVBで処理すると遅くなってしまうので、advapi32.dllを使うと簡単だし速い。
あまりサンプルが見当たらなかったので、書いてみた
ここからコピペして標準モジュールへ貼り付け。
おそらくExcel2000以上で動くと思います。
(vba6なら動くと思います)

Public Function hmac(ByVal key As String, ByVal data As String) As String
  Dim i As Integer
  Dim hash As String
  Dim key_byte() As Byte
  Dim key_len As Long
  Dim data_len As Long
  Dim ipad(63) As Byte
  Dim opad(63) As Byte
  Dim key_hash() As Byte
  Dim data_hash As String

  If key = "" And data = "" Then Exit Function

  key_len = Len(key)

  key_byte = StrConv(key, vbFromUnicode)
  If key_len > 64 Then
      key_hash = StrToBynary(CreateSHA1Hash(key_byte))
      key_len = 20
  Else
      key_hash = key_byte
  End If
  
  ReDim Preserve key_hash(63)
  For i = key_len To 63
    key_hash(i) = 0
  Next

  For i = 0 To 63
    ipad(i) = 0
    opad(i) = 0
  Next

  For i = 0 To 63
    ipad(i) = key_hash(i) Xor &H36
    opad(i) = key_hash(i) Xor &H5C
  Next

  data_hash = CreateSHA1Hash(CStr(ipad) & StrConv(data, vbFromUnicode))

  hash = CreateSHA1Hash(CStr(opad) & CStr(StrToBynary(data_hash)))

  hmac = hash
End Function

Private Function StrToBynary(strHexString As String) As Byte()
  Dim buf() As Byte
  Dim i As Long
  
  ReDim Preserve buf(Len(CStr(strHexString)) \ 2 - 1)
  For i = 0 To Len(CStr(strHexString)) \ 2 - 1
    buf(i) = CByte("&h" & Mid(CStr(strHexString), i * 2 + 1, 2))
  Next
  StrToBynary = buf
End Function


ここを参考にしました。
【Access】vbaでhmacが正しく計算できた!! | プラプラ式技術系 Access流!
HMAC SHA256 BASE64: 逢魔時 ~トワイライト~

Posted at 23:16 in program::vba | WriteBacks (814) | Edit
Tagged as: , ,

2011/01/11

taggingプラグインを導入

tagを使用したかったので、「tagging」プラグインを導入
http://noone.org/blog/English/Computer/Web/Blosxom/Tagging%20with%20Technorati%20style%20in%20pure%20Blosxom.futile
但し、ほかのプラグインとの絡みにより先に読む必要があるため、ファイル名に「1」を付加して、最初に読み込むようにした。
Posted at 00:16 in blosxom | WriteBacks (7) | Edit
Tagged as:

2011/01/06

プラグイン追加

blosxomに下記プラグインを追加
・meta
・entries_filedate
・same_category
・headlines
Posted at 00:43 in blosxom | WriteBacks (1) | Edit
Tagged as:

2011/01/02

明けましておめでとうございます。

2011年になりました。
今年は記事が書けるように頑張ります。
Posted at 00:33 in n/a | WriteBacks (0) | Edit