前回はSkyDrive APIを利用してドラッグ&ドロップしたファイルをSkyDrive上のフォルダーにアップするVBScriptを紹介しましたが、今回は逆にSkyDrive上のフォルダーからファイルをダウンロードするVBScriptを紹介します。

※ MicrosoftアカウントとAPIの利用に必要なクライアント IDの取得方法は前回の記事をご参照ください。

Option Explicit

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"
'---------------------------------------------------------------------

Init '初期化
DownloadSkyDriveFile
MsgBox "処理が終了しました。", 64 + 4096

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

Private Sub DownloadSkyDriveFile()
'SkyDriveFileからファイルをダウンロード
  Dim filePath
  Dim filesInfo
  Dim idFolder
  Dim v, vv
  Dim i
  
  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") Or (idFolder = "Err") Or Len(idFolder) < 1 Then
    MsgBox "SkyDriveフォルダーが見つかりませんでした。", 16 + 4096
    Exit Sub
  End If
  
  'ファイルの確認
  filesInfo = GetFilesInfo(AccessToken, idFolder)
  If (filesInfo = "NoFile") Or (filesInfo = "Err") Or Len(filesInfo) < 1 Then
    MsgBox "ファイルが見つかりませんでした。", 16 + 4096
    Exit Sub
  End If
  filePath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & ChrW(92) 'ファイルの保存先:デスクトップ
  v = Split(filesInfo, vbCrLf)
  For i = LBound(v) To UBound(v)
    vv = Split(v(i), ";")
    DownloadFile filePath & vv(0), vv(1)
  Next
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 Sub DownloadFile(ByVal filePath, ByVal url)
'ファイルダウンロード
  Dim dat
  Const adTypeBinary = 1
  
  On Error Resume Next
  With CreateObject("Scripting.FileSystemObject")
    If .FileExists(filePath) Then .DeleteFile filePath
  End With
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", url, False
    .send
    If .Status = 200 Then
      dat = .responseBody
      With CreateObject("ADODB.Stream")
        .Type = adTypeBinary
        .Open
        .Write dat
        .SaveToFile filePath
        .Close
      End With
    Else
      MsgBox "ファイル保存処理が失敗しました。", 16 + 4096
      Exit Sub
    End If
  End With
  If Err.Number <> 0 Then Err.Clear: MsgBox "ファイル保存処理が失敗しました。", 16 + 4096: Exit Sub
  On Error GoTo 0
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.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 GetFilesInfo(ByVal code, ByVal id)
'SkyDriveのファイル情報(ファイル名,URL)取得
'ファイルなし:NoFile, ファイルあり:ファイル名;URL, エラー:Err
  Dim ret
  Dim js
  Dim scr
  Dim d
  Dim elm
    
  js = "": ret = "NoFile" '初期化
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", "https://apis.live.net/v5.0/" & id & "/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.appendChild elm
    scr = "var objects= eval('" & js & "').data;"
    scr = scr & "var j=0;"
    scr = scr & "for(var i in objects){"
    scr = scr & "  if(objects[i].type=='file'){"
    scr = scr & "    if(j==0){"
    scr = scr & "      document.getElementById('result').innerText=objects[i].name+"";""+objects[i].source;"
    scr = scr & "    }else{"
    scr = scr & "      document.getElementById('result').innerText=document.getElementById('result').innerText+""\n""+objects[i].name+"";""+objects[i].source;"
    scr = scr & "    }"
    scr = scr & "    j++;"
    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
  GetFilesInfo = 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.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

上記スクリプトを実行すると、”FOLDER_NAME“で指定したSkyDriveフォルダー内のファイルをデスクトップにダウンロードします。