VBScript

SkyDrive上のフォルダーからファイルをダウンロードするVBScript

前回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フォルダー内のファイルをデスクトップにダウンロードします。

関連記事

  1. Windows 10

    Microsoft Update カタログから累積更新プログラムをダウンロードするVBScript

    「累積更新プログラム」とは、その名の通りOSを最新の状態に保つための更…

  2. VBScript

    指定したフォルダ内で最も更新日時の新しいファイルのパスを取得するVBScript

    大量のログファイルから最新のファイルのみを取得する必要があったので、簡…

  3. VBScript

    Acrobatを使ってPDFファイルを結合するVBScript

    「Acrobat PDF 結合 コマンドライン」といったキーワード検索…

  4. Office関連

    Officeアプリケーションのバージョン情報ダイアログから情報を取得するVBScript

    自分の手間を減らすためのスクリプトシリーズ、今回はWordやExcel…

  5. Excel

    フォルダ内にあるExcelファイルをカウントするVBScript

    「フォルダ内 Excel 数える VBScript」といったキーワード…

  6. VBScript

    msgファイルから添付ファイルを抽出するVBScript

    「msgファイルから添付ファイルを抽出するスクリプト」といったキーワー…

コメント

  1. この記事へのコメントはありません。

Time limit is exhausted. Please reload CAPTCHA.

最近の記事

アーカイブ

RapidSSL_SEAL-90x50
PAGE TOP