Нарисовал функции для скачивания/выгрузки на ЯДиск скачивание проходит нормально, а вот с выгрузкой чего-то не так. В корень вообще не загружает, в папки грузит мягко говоря, через раз, может чего лишнего понаписал или не те объекты использовал [vba]
Код
Private Const Login$ = "Логин", Pwd$ = "Пароль" Private Const Host$ = "https://webdav.yandex.ru:443/" Public Function DownloadFile(RemoteFilePath$, SaveTo$) Dim FileContents() As Byte, LocalFilePath$ SaveTo = IIf(Right(SaveTo, 1) = "\", SaveTo, SaveTo & "\") With CreateObject("MSXML2.XMLHTTP") .Open "get", urlencode(Host & RemoteFilePath), False, Login, Pwd .setrequestheader "Host", "webdav.yandex.ru" .setrequestheader "Accept", "*/*" .setrequestheader "Authorization", "Basic " & Token .send FileContents = .responseBody End With LocalFilePath = SaveTo & StrReverse(Split(StrReverse(RemoteFilePath), "/")(0)) If Dir(LocalFilePath) <> "" Then Kill LocalFilePath Open LocalFilePath For Binary Access Write As #1 Put #1, 1, FileContents Close #1 DownloadFile = LocalFilePath End Function Public Sub UploadFile(LocalFilePath$, RemotePath$) Dim FileContents As Variant, FileName$ FileName = StrReverse(Split(StrReverse(LocalFilePath), "\")(0)) RemotePath = IIf(RemotePath <> "", RemotePath & "/", "") With CreateObject("ADODB.Stream") .Type = 1: .Open: .LoadFromFile LocalFilePath: FileContents = .Read: .Close End With With CreateObject("MSXML2.XMLHTTP") .Open "put", urlencode(Host & RemotePath & FileName), False, Login, Pwd .setrequestheader "Host", "webdav.yandex.ru" .setrequestheader "Accept", "*/*" .setrequestheader "Transfer-Encoding", "chunked" .setrequestheader "Etag", MD5(FileContents) .setrequestheader "Sha256", Sha256(FileContents) .setrequestheader "Expect", "100-continue" .setrequestheader "Content-Type", "application/binary" .setrequestheader "Authorization", "Basic " & Token .setrequestheader "Content-Length", UBound(FileContents) + 1 .send FileContents End With End Sub 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$, i%, 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 Private Function Token() With CreateObject("MSXML2.DOMDocument").createElement("b64") .DataType = "bin.base64" .nodeTypedValue = Str2Byte(Login): Token = .Text & ":" .nodeTypedValue = Str2Byte(Pwd): Token = Token & .Text End With End Function
Sub test() 'открываем файл из папки 111 в ЯДиске Workbooks.Open DownloadFile("123/1.xlsm", "D:\") 'открываем файл из корня ЯДиска Workbooks.Open DownloadFile("123.xlsx", Environ("tmp")) 'выгружаем файл в папку 123 в ЯДиске UploadFile "D:\0.xlsm", "123" 'выгружаем файл в корень в ЯДиска не грузит UploadFile "D:\0.xlsm", "" End Sub
[/vba]
Нарисовал функции для скачивания/выгрузки на ЯДиск скачивание проходит нормально, а вот с выгрузкой чего-то не так. В корень вообще не загружает, в папки грузит мягко говоря, через раз, может чего лишнего понаписал или не те объекты использовал [vba]
Код
Private Const Login$ = "Логин", Pwd$ = "Пароль" Private Const Host$ = "https://webdav.yandex.ru:443/" Public Function DownloadFile(RemoteFilePath$, SaveTo$) Dim FileContents() As Byte, LocalFilePath$ SaveTo = IIf(Right(SaveTo, 1) = "\", SaveTo, SaveTo & "\") With CreateObject("MSXML2.XMLHTTP") .Open "get", urlencode(Host & RemoteFilePath), False, Login, Pwd .setrequestheader "Host", "webdav.yandex.ru" .setrequestheader "Accept", "*/*" .setrequestheader "Authorization", "Basic " & Token .send FileContents = .responseBody End With LocalFilePath = SaveTo & StrReverse(Split(StrReverse(RemoteFilePath), "/")(0)) If Dir(LocalFilePath) <> "" Then Kill LocalFilePath Open LocalFilePath For Binary Access Write As #1 Put #1, 1, FileContents Close #1 DownloadFile = LocalFilePath End Function Public Sub UploadFile(LocalFilePath$, RemotePath$) Dim FileContents As Variant, FileName$ FileName = StrReverse(Split(StrReverse(LocalFilePath), "\")(0)) RemotePath = IIf(RemotePath <> "", RemotePath & "/", "") With CreateObject("ADODB.Stream") .Type = 1: .Open: .LoadFromFile LocalFilePath: FileContents = .Read: .Close End With With CreateObject("MSXML2.XMLHTTP") .Open "put", urlencode(Host & RemotePath & FileName), False, Login, Pwd .setrequestheader "Host", "webdav.yandex.ru" .setrequestheader "Accept", "*/*" .setrequestheader "Transfer-Encoding", "chunked" .setrequestheader "Etag", MD5(FileContents) .setrequestheader "Sha256", Sha256(FileContents) .setrequestheader "Expect", "100-continue" .setrequestheader "Content-Type", "application/binary" .setrequestheader "Authorization", "Basic " & Token .setrequestheader "Content-Length", UBound(FileContents) + 1 .send FileContents End With End Sub 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$, i%, 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 Private Function Token() With CreateObject("MSXML2.DOMDocument").createElement("b64") .DataType = "bin.base64" .nodeTypedValue = Str2Byte(Login): Token = .Text & ":" .nodeTypedValue = Str2Byte(Pwd): Token = Token & .Text End With End Function
Sub test() 'открываем файл из папки 111 в ЯДиске Workbooks.Open DownloadFile("123/1.xlsm", "D:\") 'открываем файл из корня ЯДиска Workbooks.Open DownloadFile("123.xlsx", Environ("tmp")) 'выгружаем файл в папку 123 в ЯДиске UploadFile "D:\0.xlsm", "123" 'выгружаем файл в корень в ЯДиска не грузит UploadFile "D:\0.xlsm", "" End Sub
наверно не успевает файл сохраниться, пробуйте так [vba]
Код
Private Declare Function CreateFile _ Lib "kernel32" _ Alias "CreateFileA" ( _ ByVal lpFileName As String, _ ByVal dwDesiredAccess As Long, _ ByVal dwShareMode As Long, _ ByRef lpSecurityAttributes As Any, _ ByVal dwCreationDistribution As Long, _ ByVal dwFlagsAndAttributes As Long, _ ByVal hTemplateFile As Long _ ) As Long Private Declare Function CloseHandle _ Lib "kernel32" ( _ ByVal hObject As Long _ ) As Long Sub Макрос1() ' ' Макрос1 Макрос '
' Sheets("Лист2").Select ActiveWorkbook.RefreshAll Sheets("Лист3").Select Range("A1").Select ActiveSheet.PivotTables("СводнаяТаблица3").PivotFields("Shipping Order"). _ ClearAllFilters With ActiveSheet.PivotTables("СводнаяТаблица3").PivotFields("Shipping Order") .PivotItems("").Visible = False .PivotItems("(пусто)").Visible = False End With Sheets("Лист1").Select ActiveWorkbook.RefreshAll Dim Wb As Workbook Dim WbName As String Dim iPath As String Dim iFilePath As String Set Wb = ActiveWorkbook WbName = Wb.FullName iPath = ThisWorkbook.Path & "\" iFilePath = Left(WbName, InStrRev(WbName, ".") - 1) + " " + Format(Date, "dd/mm/yyyy") + ".xls" If Dir(iFilePath) <> "" Then MsgBox "Копия файла c датой " & Format(Date, "yyyy/mm/dd") & " в директории " & Chr(13) & iPath$ & " уже существует!", vbExclamation Exit Sub End If Wb.SaveCopyAs iFilePath Dim IsSaved As Boolean Do Until IsSaved hfile = CreateFile(FilePath, &H80000000, &H1, 0, 3, 0, 0) IsSaved = hfile <> -1 CloseHandle hfile DoEvents Loop Workbooks.Open iFilePath Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Sheets("Лист2").Select ActiveWindow.SelectedSheets.Delete Sheets("Лист3").Select ActiveWindow.SelectedSheets.Delete Sheets("Лист4").Select ActiveWindow.SelectedSheets.Delete End Sub
наверно не успевает файл сохраниться, пробуйте так [vba]
Код
Private Declare Function CreateFile _ Lib "kernel32" _ Alias "CreateFileA" ( _ ByVal lpFileName As String, _ ByVal dwDesiredAccess As Long, _ ByVal dwShareMode As Long, _ ByRef lpSecurityAttributes As Any, _ ByVal dwCreationDistribution As Long, _ ByVal dwFlagsAndAttributes As Long, _ ByVal hTemplateFile As Long _ ) As Long Private Declare Function CloseHandle _ Lib "kernel32" ( _ ByVal hObject As Long _ ) As Long Sub Макрос1() ' ' Макрос1 Макрос '
' Sheets("Лист2").Select ActiveWorkbook.RefreshAll Sheets("Лист3").Select Range("A1").Select ActiveSheet.PivotTables("СводнаяТаблица3").PivotFields("Shipping Order"). _ ClearAllFilters With ActiveSheet.PivotTables("СводнаяТаблица3").PivotFields("Shipping Order") .PivotItems("").Visible = False .PivotItems("(пусто)").Visible = False End With Sheets("Лист1").Select ActiveWorkbook.RefreshAll Dim Wb As Workbook Dim WbName As String Dim iPath As String Dim iFilePath As String Set Wb = ActiveWorkbook WbName = Wb.FullName iPath = ThisWorkbook.Path & "\" iFilePath = Left(WbName, InStrRev(WbName, ".") - 1) + " " + Format(Date, "dd/mm/yyyy") + ".xls" If Dir(iFilePath) <> "" Then MsgBox "Копия файла c датой " & Format(Date, "yyyy/mm/dd") & " в директории " & Chr(13) & iPath$ & " уже существует!", vbExclamation Exit Sub End If Wb.SaveCopyAs iFilePath Dim IsSaved As Boolean Do Until IsSaved hfile = CreateFile(FilePath, &H80000000, &H1, 0, 3, 0, 0) IsSaved = hfile <> -1 CloseHandle hfile DoEvents Loop Workbooks.Open iFilePath Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Sheets("Лист2").Select ActiveWindow.SelectedSheets.Delete Sheets("Лист3").Select ActiveWindow.SelectedSheets.Delete Sheets("Лист4").Select ActiveWindow.SelectedSheets.Delete End Sub
Private Const Login$ = "Логин", Pwd$ = "Пароль" Private Const Host$ = "https://webdav.yandex.ru:443/" Public Function DownloadFile(RemoteFilePath$, SaveTo) Dim FileContents() As Byte, LocalFilePath$ SaveTo = IIf(Right(SaveTo, 1) = "\", SaveTo, SaveTo & "\") With CreateObject("WinHttp.WinHttpRequest.5.1") .Open "GET", urlencode(Host & RemoteFilePath$), True .SetRequestHeader "Host", "webdav.yandex.ru" .SetRequestHeader "Accept", "*/*" .SetRequestHeader "Authorization", "Basic " & Token .send .WaitForResponse FileContents = .responseBody End With LocalFilePath = SaveTo & StrReverse(Split(StrReverse(RemoteFilePath), "/")(0)) If Dir(LocalFilePath) <> "" Then Kill LocalFilePath Open LocalFilePath For Binary Access Write As #1 Put #1, 1, FileContents Close #1 DownloadFile = LocalFilePath End Function Public Sub UploadFile(LocalFilePath$, RemotePath$) Dim FileContents As Variant, FileName$ FileName = StrReverse(Split(StrReverse(LocalFilePath), "\")(0)) RemotePath = IIf(RemotePath <> "", RemotePath & "/", "") With CreateObject("ADODB.Stream") .Type = 1: .Open: .LoadFromFile LocalFilePath: FileContents = .Read: .Close End With With CreateObject("WinHttp.WinHttpRequest.5.1") .Open "PUT", urlencode(Host & RemotePath & FileName), False .SetRequestHeader "Host", "webdav.yandex.ru" .SetRequestHeader "Accept", "*/*" .SetRequestHeader "Etag", MD5(FileContents) .SetRequestHeader "Sha256", Sha256(FileContents) .SetRequestHeader "Expect", "100-continue" .SetRequestHeader "Content-Type", "application/binary" .SetRequestHeader "Authorization", "Basic " & Token .SetRequestHeader "Content-Length", UBound(FileContents) + 1 .send FileContents .WaitForResponse Debug.Print "Файл "; IIf(.StatusText = "Created", "успешно загружен", "не загружен") End With End Sub 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$, i%, 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 Private Function Token() With CreateObject("MSXML2.DOMDocument").createElement("b64") .DataType = "bin.base64" .nodeTypedValue = Str2Byte(Login & ":" & Pwd): Token = .Text End With End Function
[/vba]
Исправил свой код, так должно работать [vba]
Код
Private Const Login$ = "Логин", Pwd$ = "Пароль" Private Const Host$ = "https://webdav.yandex.ru:443/" Public Function DownloadFile(RemoteFilePath$, SaveTo) Dim FileContents() As Byte, LocalFilePath$ SaveTo = IIf(Right(SaveTo, 1) = "\", SaveTo, SaveTo & "\") With CreateObject("WinHttp.WinHttpRequest.5.1") .Open "GET", urlencode(Host & RemoteFilePath$), True .SetRequestHeader "Host", "webdav.yandex.ru" .SetRequestHeader "Accept", "*/*" .SetRequestHeader "Authorization", "Basic " & Token .send .WaitForResponse FileContents = .responseBody End With LocalFilePath = SaveTo & StrReverse(Split(StrReverse(RemoteFilePath), "/")(0)) If Dir(LocalFilePath) <> "" Then Kill LocalFilePath Open LocalFilePath For Binary Access Write As #1 Put #1, 1, FileContents Close #1 DownloadFile = LocalFilePath End Function Public Sub UploadFile(LocalFilePath$, RemotePath$) Dim FileContents As Variant, FileName$ FileName = StrReverse(Split(StrReverse(LocalFilePath), "\")(0)) RemotePath = IIf(RemotePath <> "", RemotePath & "/", "") With CreateObject("ADODB.Stream") .Type = 1: .Open: .LoadFromFile LocalFilePath: FileContents = .Read: .Close End With With CreateObject("WinHttp.WinHttpRequest.5.1") .Open "PUT", urlencode(Host & RemotePath & FileName), False .SetRequestHeader "Host", "webdav.yandex.ru" .SetRequestHeader "Accept", "*/*" .SetRequestHeader "Etag", MD5(FileContents) .SetRequestHeader "Sha256", Sha256(FileContents) .SetRequestHeader "Expect", "100-continue" .SetRequestHeader "Content-Type", "application/binary" .SetRequestHeader "Authorization", "Basic " & Token .SetRequestHeader "Content-Length", UBound(FileContents) + 1 .send FileContents .WaitForResponse Debug.Print "Файл "; IIf(.StatusText = "Created", "успешно загружен", "не загружен") End With End Sub 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$, i%, 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 Private Function Token() With CreateObject("MSXML2.DOMDocument").createElement("b64") .DataType = "bin.base64" .nodeTypedValue = Str2Byte(Login & ":" & Pwd): Token = .Text End With End Function
может быть, но, чтобы решение было прям совсем готовое, нужно (имхо) его дополнить проверками на ошибки и хоть немного откомментировать, а на это у мну сейчас времени немного не хватает
может быть, но, чтобы решение было прям совсем готовое, нужно (имхо) его дополнить проверками на ошибки и хоть немного откомментировать, а на это у мну сейчас времени немного не хватает krosav4ig
Эт я просто забыл, каким методом логин/пароль задавать, вот и решил посмотреть (на всякий случай, вдруг в проксю упрется). В MSDN лезть лень, добавил референс, зачем-то обьявил переменную, полез в object explorer, поковырялся там, нашел SetCredentials, но не нашел никакой инфы про HTTPREQUEST_SETCREDENTIALS_FLAGS, все равно пришлось лезть в MSDN, референс отключил, а переменную затереть забыл
Эт я просто забыл, каким методом логин/пароль задавать, вот и решил посмотреть (на всякий случай, вдруг в проксю упрется). В MSDN лезть лень, добавил референс, зачем-то обьявил переменную, полез в object explorer, поковырялся там, нашел SetCredentials, но не нашел никакой инфы про HTTPREQUEST_SETCREDENTIALS_FLAGS, все равно пришлось лезть в MSDN, референс отключил, а переменную затереть забыл krosav4ig
ilya-yurasov, если все-таки пользоваться макрофункциями, то лучше вторым вариантом из моего поста (с листом макросов), ибо могут возникнуть проблемы в расчетах при переключении на другие книги. по поводу формулы - забыл указать последний аргумент. Должно быть так
Код
=ВПР(A3;cc;9;)
Добавил UDF [vba]
Код
Function ПредыдущийЛист() As Range With Parent.Caller.Parent Set ПредыдущийЛист = .Parent.Sheets(.Index - 1).UsedRange End With End Function
[/vba]
ilya-yurasov, если все-таки пользоваться макрофункциями, то лучше вторым вариантом из моего поста (с листом макросов), ибо могут возникнуть проблемы в расчетах при переключении на другие книги. по поводу формулы - забыл указать последний аргумент. Должно быть так
Код
=ВПР(A3;cc;9;)
Добавил UDF [vba]
Код
Function ПредыдущийЛист() As Range With Parent.Caller.Parent Set ПредыдущийЛист = .Parent.Sheets(.Index - 1).UsedRange End With End Function