VBScript

ドラッグ&ドロップしたファイルを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を使用しています。半ば無理やり処理しているところもあるので、全体的に何だか泥臭い処理になってしまいました・・・。

[Excel 2013]Web関数を使ってマッシュアップ前のページ

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

関連記事

  1. Windows関連

    OSのバージョン情報をクリップボードにコピーするVBScript

    OSのバージョンやビルド番号をブログの記事内に書くことがあるのですが、…

  2. VBScript

    Internet Explorerのお気に入りを列挙するVBScript

    Internet Explorerのお気に入りにどの位のインターネット…

  3. Excel

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

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

  4. Office関連

    Officeアプリケーションの「最近使用したファイル」を削除するVBScript

    WordやExcel等のOfficeアプリケーションでは、下記サイトに…

  5. VBScript

    Office文書を旧バージョンのファイル形式に変換するVBScript

    xlsxやdocxといった新しい形式のOffice文書をスクリプトファ…

  6. VBScript

    Windows Updateの更新履歴をCSV(UTF-8)で保存するVBScript

    以前書いたスクリプトが出てきました。Windows Updateの…

コメント

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

Time limit is exhausted. Please reload CAPTCHA.

※本ページはプロモーションが含まれています。

Translate

最近の記事

アーカイブ

PAGE TOP