Bit.lyで短縮するVBScript

(5/6 15:47更新)
先日のAppleScript版に続き、VBScriptのほうも修正したので、更新して
再掲しておきます。
—

TwitterにURLを貼る場合、URL短縮サービスを使うことが多々あります。
最近のクライアントは自動でやってくれるものも多いですが、なぜか
うまくいかなかったりすることもありますよね。

というわけで、事前にクリップボードに入ったURLを短縮しちゃう
スクリプトを作ってみました。
Macではアップルスクリプトのものは先日掲載したので、次はVBScriptで。
ソースはこんな感じになりました。

s = GetClipText

if Left(s, 4) = “http” Then
    result = BitlyPost(s)
    If result = “” Then
        Msgbox “URLの短縮に失敗しました。”
        WScript.Quit
    End If
    SetClipText result
Else
    Msgbox “クリップボードにURLがセットされていません。”
End If

WScript.Quit

Function BitlyPost(url)

    sURL = “http://api.bit.ly/v3/shorten?login=★ユーザー名★&apiKey=★APIキー★&uri=” & url & “&format=txt”

    Set oHTTP = WScript.CreateObject(“Msxml2.XMLHTTP”)

    oHTTP.Open “GET”, sURL, False
    oHTTP.send

    BitlyPost = oHttp.responseText

End Function

Function GetClipText

    Set uf=CreateObject(“Forms.Form.1”)
    Set tb=uf.Controls.Add(“Forms.TextBox.1”).Object
    tb.MultiLine=True
    If tb.CanPaste Then
       tb.Paste
       GetClipText = tb.Text
    End If

    Set tb=Nothing
    Set uf=Nothing

End Function

Function SetClipText(s)

    Set uf=CreateObject(“Forms.Form.1”)
    Set tb=uf.Controls.Add(“Forms.TextBox.1”).Object
    tb.MultiLine=True
    tb.Text=s
    tb.SelStart=0
    tb.SelLength=tb.TextLength
    tb.Copy

    Set tb=Nothing
    Set uf=Nothing

End Function

クリップボードへのアクセスがWindows標準ではできないので、ここでは
Officeを利用しています。
IEでも可能なんですが、セキュリティ設定によっては動作しないことが
あるんですよねぇ。
ということで、しょぼいスクリプトのわりにはOffice必須です。(^^;

なお、クリップボードの取得・設定方法につきましては、以下のサイト様の
情報をそのまま利用させていただきました。感謝、感謝であります。
http://winscript.s41.xrea.com/wiki/index.php?[[FAQ]]#content_1_4

AppleScriptのほうはurlencode必須でしたが、Windowsのブラウザは
urlencodeした状態で返してくれるようなので、そのまま何もしていません。
一応うまくいってるようですが、あくまでもサンプルみたいなものですので、
自己責任でご利用いただければ幸いです。
なお、スクリプトファイルは下の場所にも置いておきました。
http://saramac.main.jp/fw/bitly.vbs