В документации написано, что надо зарегистрировать приложение в https://oauth.yandex.ru/ Тогда будет токен и id
В api Яндекс диск дан пример запроса на загрузку
Код
Пример запроса
Приложение загружает файл otpusk.avi в каталог /a/ на Диске пользователя, указывая контрольную сумму и хэш для проверки дубликатов.PUT /a/otpusk.avi HTTP/1.1
Host: webdav.yandex.ru
Accept: */*
Authorization: OAuth 0c4181a7c2cf4521964a72ff57a34a07
Etag: 1bc29b36f623ba82aaf6724fd3b16718
Sha256: T8A8H6B407D7809569CA9ABCB0082E4F8D5651E46D3CDB762D02D0BF37C9E592
Expect: 100-continue
Content-Type: application/binary
Content-Length: 103134024
Я так понимаю изменили авторизацию и теперь для авторизации нужен только токен
Адаптировал процедуру
Код
Private Function Str2Byte(str$) As Byte()
Str2Byte = StrConv(str, vbFromUnicode)
End Function
Private Function urlencode$(url)
With CreateObject("scriptcontrol")
.Language = "JavaScript"
urlencode = .eval("encodeURI('" & url & "')")
End With
End Function
Private Function MD5(ByVal bytes) As String
Dim sTmp$, i%, byteArr() As Byte
byteArr = bytes
With CreateObject("System.Security.Cryptography.MD5CryptoServiceProvider")
byteArr = .ComputeHash_2(byteArr)
End With
For i = 0 To UBound(byteArr)
sTmp = sTmp & LCase(Right("0" & Hex(byteArr(i)), 2))
Next
MD5 = sTmp
End Function
Private Function Sha256(ByVal bytes) As String
Dim sTmp As String
Dim i As Integer
Dim byteArr() As Byte
byteArr = bytes
With CreateObject("System.Security.Cryptography.SHA256Managed")
byteArr = .ComputeHash_2(byteArr)
End With
For i = 0 To UBound(byteArr)
sTmp = sTmp & LCase(Right("0" & Hex(byteArr(i)), 2))
Next
Sha256 = sTmp
End Function
Public Sub ÇàãðóçêàÔàéëà()
Dim FileContents As Variant
Dim FileName As String
Dim stream As Object
Dim http As Object
Dim LocalFilePath As String
Dim RemotePath As String
LocalFilePath = "c:\#work\777(minus).mp3"
RemotePath = "777.mp3"
Host_disk = "https://webdav.yandex.ru/"
RemotePath = Host_disk & RemotePath & "/"
api_token = "e8cdc14be1604caeb4d2aac960a6027c"
id_token = "e8cdc14be1604caeb4d2aac960a6027c"
Set stream = CreateObject("ADODB.Stream")
With stream
.Type = 1
.Open
.LoadFromFile LocalFilePath
FileContents = .Read
.Close
End With
Set http_disk = CreateObject("WinHttp.WinHttpRequest.5.1")
With http_disk
.Open "PUT", urlencode(RemotePath)
.setRequestHeader "Host", "webdav.yandex.ru"
.setRequestHeader "Accept", "*/*"
.setRequestHeader "Etag", MD5(FileContents)
.setRequestHeader "Sha256", Sha256(FileContents)
.setRequestHeader "Expect", "100-continue"
.setRequestHeader "Content-Type", "application/binary"
Êëþ÷ = "oauth_token=" & Chr(34) & api_token & Chr(34)
Êëþ÷1 = " oauth_client_id=" & Chr(34) & id_token & Chr(34)
.setRequestHeader "Authorization", "OAuth " & Êëþ÷, Êëþ÷1
.setRequestHeader "Content-Length", UBound(FileContents) + 1
.send FileContents
.WaitForResponse
Debug.Print .StatusText
End With
End Sub
Function WebDavDsk(lgn$, psw$, Optional fldr$) As String
Dim fso As Object, netDsk As Object, dskPath$, i&
Set netDsk = CreateObject("WScript.Network")
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For i = 65 To 90
dskPath = Chr(i) & ":"
If Not fso.DriveExists(dskPath) Then
netDsk.MapNetworkDrive dskPath, "https://webdav.yandex.ru:443/" & fldr, False, lgn, psw
If Err.Number = 0 Then Exit For Else dskPath = "": Err.Clear
End If
Next
On Error GoTo 0
WebDavDsk = dskPath
End Function
Sub NetDskOff(dskPath$)
Dim fso As Object, x, netDsk As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set netDsk = CreateObject("WScript.Network")
On Error Resume Next
For Each x In fso.Drives
dskPath = x.Path: If fso.FolderExists(dskPath) Then netDsk.RemoveNetworkDrive dskPath, True, True: Exit For
Next
End Sub
Sub ПримерИспользования()
Dim БукваПодключаемогоДиска$
БукваПодключаемогоДиска = WebDavDsk("Логин", "Пароль", "Папка")
'vcomp71 написал: Загрузить файл, скачать, создать директорию, переименовать
'Здесь все это делаем что хотели
NetDskOff БукваПодключаемогоДиска 'Отключаем диск после работы
End Sub