ドラッグ&ドロップしたファイルをSkyDrive上のフォルダーにアップするVBScript

ホーム
VBScript
ドラッグ&ドロップしたファイルをSkyDrive上のフォルダーにアップするVBScript

2012.12.7

ドラッグ&ドロップしたファイルをSkyDrive上のフォルダーにアップするVBScript

2012/12/19 追記：
・関連記事「SkyDrive上のフォルダーからファイルをダウンロードするVBScript」もご参照ください。

Microsoftが提供している無料のオンラインストレージ「SkyDrive」は非常に便利で利用している人も多いだろうと思います。
今回はSkyDrive APIを利用してドラッグ&ドロップしたファイルをSkyDrive上のフォルダーにアップするVBScriptを紹介します。

※ SkyDriveが利用できることが前提ですので、Microsoftアカウント(旧Windows Live ID)を持っていない方は「Microsoft アカウントホーム」からアカウントを取得してください。

まずは、APIを利用するのに必要なクライアント IDを取得します。
Live Connect デベロッパーセンターの中から「マイアプリ」を開きます。

「アプリケーションの作成」をクリックします。

アプリケーション名と言語を入力して「同意する」をクリックします。

API設定画面が開かれ、「クライアント ID」と「クライアントシークレット」が表示されます。
今回のスクリプトでは「クライアント ID」のみ使用します。

以上で準備は終了です。
下記スクリプト内の「CLIENT_ID」の値を上記作業で取得したクライアント IDに、「FOLDER_NAME」の値をアップしたいSkyDrive上のフォルダー名に書き換え、スクリプトファイルにアップしたいファイルをドラッグ&ドロップすると、ファイルが自動的にアップロードされます。

その際サインインとアクセス許可を求められるので、”マイアプリ“登録に使用したMicrosoft アカウントでサインインしてください。

Option Explicit

Dim Arg
Dim Args
Dim IE
Dim FlgIeQuit
Dim ParamGet
Dim AccessToken
Dim AuthenticationToken
Dim ExpiresIn
Dim DateExpires

'---------------------------------------------------------------------
'※ 要変更
'---------------------------------------------------------------------
Const FOLDER_NAME = "サンプルフォルダー"
'クライアント ID
Const CLIENT_ID = "****************"
'リダイレクト ドメイン(API設定で自分でドメインを指定した場合のみ変更)
Const REDIRECT_URL = "https://oauth.live.com/desktop"
'---------------------------------------------------------------------

Set Args = WScript.Arguments
If Args.Count < 1 Then
  MsgBox "SkyDriveにアップしたいファイルを当スクリプトファイルにドラッグ&ドロップしてください。", 16 + 4096
  WScript.Quit
End If
Init '初期化
For Each Arg In Args
  UploadSkyDriveFile Arg
Next
MsgBox "処理が終了しました。", 64 + 4096

Private Sub Init()
'各変数初期化
  FlgIeQuit = 0
  ParamGet = ""
  AccessToken = ""
  AuthenticationToken = ""
  ExpiresIn = ""
  DateExpires = ""
End Sub

Private Sub UploadSkyDriveFile(ByVal filePath)
'SkyDriveFileにファイルをアップロード
  Dim fileName
  Dim idFolder
  Dim dat
  
  If (DateExpires <> "") And (Now() < DateExpires) Then
  Else
    AuthenticateSkyDrive '認証
  End If
  If AccessToken = "" Then
    MsgBox "アクセストークンの取得に失敗しました。", 16 + 4096
    Exit Sub
  End If
  
  'フォルダーの確認・作成
  idFolder = GetSkyDriveFolderId(AccessToken, FOLDER_NAME)
  If idFolder = "NoFolder" Then idFolder = CreateSkyDriveFolder(AccessToken, FOLDER_NAME)
  If (idFolder = "Err") Or Len(idFolder) < 1 Then
    MsgBox "SkyDriveフォルダーの確認・作成処理が失敗しました。", 16 + 4096
    Exit Sub
  End If
  dat = GetStream(filePath)
  fileName = CreateObject("Scripting.FileSystemObject").GetFileName(filePath) 'ファイル名取得
  With CreateObject("MSXML2.XMLHTTP")
    .Open "PUT", "https://apis.live.net/v5.0/" & idFolder & "/files/" & EncodeURL(fileName) & "?overwrite=true", False
    .setRequestHeader "Authorization", "Bearer " & AccessToken
    .send dat
    Select Case .Status
      Case 200, 201:
      Case Else
        MsgBox "ファイルのアップロード処理が失敗しました。", 16 + 4096
        Exit Sub
    End Select
  End With
End Sub

Private Sub AuthenticateSkyDrive()
'SkyDrive認証
  Dim url
  Dim scope
  Dim timeLimit
  
  Set IE = Nothing '初期化
  scope = "wl.skydrive_update wl.offline_access"
  url = "http://oauth.live.com/authorize?locale=ja&display=page&client_id=" & EncodeURL(CLIENT_ID) & "&scope=" & EncodeURL(scope) & "&response_type=token&redirect_uri=" & EncodeURL(REDIRECT_URL)
  Set IE = WScript.CreateObject("InternetExplorer.Application", "IE_")
  On Error Resume Next
  With IE
    .Visible = True
    .Toolbar = False
    .AddressBar = False
    .MenuBar = False
    .Top = 50
    .Left = 200
    .Width = 400
    .Height = 500
    .Navigate url
    'While .Busy Or .readyState <> 4
    '  WScript.Sleep 100
    'Wend
    timeLimit = DateAdd("s", 60, Now()) 'ループの制限時間:60秒
    Do
      WScript.Sleep 100
      If FlgIeQuit = 1 Then Exit Do
      If Now() > timeLimit Then Exit Do '制限時間を過ぎたらループを抜ける
    Loop While ParamGet = ""
    If FlgIeQuit = 0 Then .Quit
  End With
  If Err.Number <> 0 Then
    MsgBox "エラーが発生しました。" & vbCrLf & "内容:" & Err.Description, 16 + 4096
    Exit Sub
  End If
  On Error GoTo 0
  If ParamGet = "" Then
    MsgBox "ユーザー認証に失敗しました。", 16 + 4096
    Exit Sub
  End If
  GetToken ParamGet
End Sub

Private Sub GetToken(ByVal param)
'各トークン取得
  Dim v, vv
  Dim i
  
  param = Replace(param, REDIRECT_URL & "#", "")
  v = Split(param, "&")
  For i = LBound(v) To UBound(v)
    vv = Split(v(i), "=")
    Select Case LCase(Trim(vv(0)))
      Case "access_token": AccessToken = vv(1)
      Case "expires_in": ExpiresIn = vv(1): DateExpires = DateAdd("s", CDbl(ExpiresIn), Now()) 'アクセストークンの有効時間設定
      Case "authentication_token": AuthenticationToken = vv(1)
    End Select
  Next
End Sub

Private Function GetSkyDriveFolderId(ByVal code, ByVal fn)
'SkyDriveのフォルダーID取得
'フォルダーなし:NoFolder, フォルダーあり:id, エラー:Err
  Dim ret
  Dim js
  Dim scr
  Dim d
  Dim elm
    
  js = "": ret = "NoFolder" '初期化
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", "https://apis.live.net/v5.0/me/skydrive/files", False
    .setRequestHeader "Authorization", "Bearer " & code
    .send
    If .Status = 200 Then js = .responseText
  End With
  If Len(js) > 0 Then
    js = Replace(js, vbCr, "")
    js = Replace(js, vbLf, "")
    js = Replace(js, vbCrLf, "")
    js = "(" & js & ")"
    Set d = CreateObject("htmlfile")
    Set elm = d.createElement("span")
    elm.setAttribute "id", "result"
    d.body.appendChild elm
    scr = "var objects= eval('" & js & "').data;"
    scr = scr & "for(var i in objects){"
    scr = scr & "  if(objects[i].type=='folder' && objects[i].name=='" & fn & "'){"
    scr = scr & "    document.getElementById('result').innerText=objects[i].id;"
    scr = scr & "  }"
    scr = scr & "}"
    d.parentWindow.execScript scr
    If Len(elm.innerText) > 0 Then ret = elm.innerText
  End If
  If Err.Number <> 0 Then Err.Clear: ret = "Err"
  On Error GoTo 0
  GetSkyDriveFolderId = ret
End Function

Private Function CreateSkyDriveFolder(ByVal code, ByVal fn)
'SkyDriveにフォルダー作成
  Dim js
  Dim ret
  Dim d
  Dim elm
  
  js = "": ret = "" '初期化
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    .Open "POST", "https://apis.live.net/v5.0/me/skydrive/", False
    .setRequestHeader "Authorization", "Bearer " & code
    .setRequestHeader "Content-Type", "application/json"
    .send "{""name"": """ & fn & """}"
    If .Status = 201 Then js = .responseText
  End With
  If Len(js) > 0 Then
    js = Replace(js, vbCr, "")
    js = Replace(js, vbLf, "")
    js = Replace(js, vbCrLf, "")
    js = "(" & js & ")"
    Set d = CreateObject("htmlfile")
    Set elm = d.createElement("span")
    elm.setAttribute "id", "result"
    d.body.appendChild elm
    d.parentWindow.execScript "document.getElementById('result').innerText=eval('" & js & "').id;"
    ret = elm.innerText
  End If
  If Err.Number <> 0 Then Err.Clear: ret = "Err"
  On Error GoTo 0
  CreateSkyDriveFolder = ret
End Function

Private Function GetStream(ByVal filePath)
  Dim ret
  Const adTypeBinary = 1
  
  With CreateObject("ADODB.Stream")
    .type = adTypeBinary
    .Open
    .LoadFromFile filePath
    ret = .Read(-1)
    .Close
  End With
  GetStream = ret
End Function

Private Function EncodeURL(ByVal sWord)
  Dim d
  Dim elm
  
  sWord = Replace(sWord, "\", "\\")
  sWord = Replace(sWord, "'", "\'")
  Set d = CreateObject("htmlfile")
  Set elm = d.createElement("span")
  elm.setAttribute "id", "result"
  d.body.appendChild elm
  d.parentWindow.execScript "document.getElementById('result').innerText=encodeURIComponent('" & sWord & "');"
  EncodeURL = elm.innerText
End Function

Public Sub IE_DocumentComplete(ByVal pDisp, url)
  If InStr(url, REDIRECT_URL & "#access_token=") Then ParamGet = url
End Sub

Public Sub IE_OnQuit()
  FlgIeQuit = 1
End Sub

JSONデータを扱う際に、64ビット環境ではScriptControlが使えないので代わりにHTMLDocumentを使用しています。半ば無理やり処理しているところもあるので、全体的に何だか泥臭い処理になってしまいました・・・。