Thanks for this excellent resource, it has been of great assistance to me, but I am having a problem using excel VBA to download excel files from a remote server. I suspect it is something obvious that my code is lacking.
The problem I am having is that all the downloaded files are always 15KB in size, regardless of the size or content of the original file and all bear the same content which appears to be text simply copied from the host website, rather than the file I am trying to download. I have tried using various file extensions including CSV but the results are the same.
When I open the downloaded file excel says the file format and extension don't match and then says that, due to problems during load, the file is "missing file C:\remote\css\logon.css" and "missing file C:\remote\javascript\ramjsfx.menu.css", which is Greek to me.
Sub DownloadFilefromWeb()
Const E_OUTOFMEMORY As Long = &H8007000E
Const E_DOWNLOAD_FAILURE As Long = &H800C0002
Dim InitialName As String
Dim Msg As String
Dim RegExp As Object
Dim RetVal As Long
Dim SaveName As String
Dim SavePath As String
Dim URL As String
URL = InputBox("Enter the download URL below.", "Download from Internet")
If URL = "" Then Exit Sub
Set RegExp = CreateObject("VBScript.RegExp")
RegExp.IgnoreCase = True
RegExp.Pattern = "^(.*\/)(.+)$"
InitialName = RegExp.Replace(URL, "$2")
Set RegExp = Nothing
If InitialName = "" Or InitialName = URL Then
MsgBox ("Error - Missing File Name")
Exit Sub
End If
SavePath = Application.GetSaveAsFilename(InitialName)
If SavePath = "" Then Exit Sub
'SavePath = "C:\Users\Rob's Laptop\Documents\Test\Test3.xls"
'URL = "https://remote.picosting.co.uk/Remote/fs/files.aspx?path=%5c%5cPISBS2011%5cfiles%5cRob% 20Shaw%27s%20test%20folder%5cTest1"
RetVal = URLDownloadToFile(0&, URL, SavePath, 0&, 0&)
Select Case RetVal
Case 0
Msg = "Download Successful"
Case E_OUTOFMEMORY
Msg = "Error - Out of Mmemory"
Case E_DOWNLOAD_FAILURE
Msg = "Error - Bad URL or Connection Interrupted"
Case Else
Msg = "Unknown Error - " & RetVal
End Select
MsgBox Msg
End Sub
Kind regards
Rob
URLDownloadToFile() is literally and simply downloading the .aspx page that is on the server - when accessed through a normal web broswer, that page does server side logic to obtain and download the Excel file you are trying to get. The css files it is complaining about are stylesheet files that are used to control the display of the .aspx page.
You will need to use something more complex than URLDownloadToFile() to save the file that you want, for example setting up an IE Application object as described here:
http://www.mrexcel.com/forum/excel-questions/502298-need-help-regarding-ie-automation-using-visual-basic-applications.html
Related
I am trying to link Sharepoint 365 into an Excel Workbook. Previously, I was using wshell to mount the Sharepoint drive to my computer and access everything locally. Sharepoint 365 doesn't allow you to do that, so I am using the API. Here are my steps:
Login to Sharepoint and get an access token (OAuth2 handshake)
Search for a file or navigate Sharepoint List/Folder/File tree to find a file (this is done through various Sharepoint API calls returning the relevant objects I am looking for)
Download the file from Sharepoint onto the local drive (read only operations at the moment)
There are a bunch of automated procedures I have been using to interact with data downloaded from various files, this will not change.
With the Sharepoint 365 API, I am stuck at step 3.
I'm using a class to instantiate my Sharepoint session and keep track of my file object. My unit test looks like this:
Sub testDownload()
Dim spFile As New sp365
Dim reqObj As Object
Dim jsonObj As Object
Dim dlStatus As Long
'first log in
spFile.login
'now get a request object that contains filenames and their relative URLs
Set reqObj = spFile.testQuery
'extract the info to a JSON object
Set jsonObj = jsonify(reqObj.responseText, "")
'hardcoding these parameters for now because I just want to download this one file
Debug.Print "Filename: " & jsonObj("d.results(0).Name")
Debug.Print "Relative Url: " & jsonObj("d.results(0).ServerRelativeUrl")
dlStatus = spFile.downloadTemporaryFile(jsonObj("d.results(0).ServerRelativeUrl"), jsonObj("d.results(0).Name"))
If dlStatus = 0 Then
Debug.Print "File Created"
Else
Debug.Print "File not created. Status = " & dlStatus
End If
out:
Exit Sub
End Sub
The relevant code here lies in downloadTemporaryFile. Obviously, I am using the windows urlmon code, which seems to be the de facto way to download files in Excel:
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" ( _
ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
And downloading the (temporary) file is here:
Function downloadTemporaryFile(relativeUrl As String, fileName As String) As Boolean
On Error GoTo errHandler
'Download a file to a temporary path
'Keep the file inside the class object until it is closed
Dim userPath As String
Dim filePath As String
Dim url As String
Dim wshShell As Object
'Get the windows shell version for special folders
Set wshShell = CreateObject("WScript.Shell")
'get the documents folder for this computer
userPath = wshShell.SpecialFolders("MyDocuments")
'all logs are stored in <user>/Documents/logs
filePath = userPath & SHAREPOINT_TEMP_FOLDER
'Check if the 'SharepointTemp' folder exists
'if not, create the directory
If Dir(filePath, vbDirectory) = "" Then MkDir (filePath)
'Extract the site (this can differ based on the connected app)
'FYI: TENANT_DOMAIN is obtained during the Sharepoint Login procedure
url = "https://" & TENANT_DOMAIN & relativeUrl
'download it now
Debug.Print "Downloading to: " & filePath & fileName
Debug.Print "Downloading from: " & url
downloadTemporaryFile = URLDownloadToFile(0, url, filePath & fileName, 0, 0)
out:
Exit Function
errHandler:
logDump "Error", "sp365.downloadTemporaryFile", Err.Number & ";" & Err.source & ";" & Err.description
End Function
So this seems like it would work, and URLDownloadToFile returns 0 (S_OK). But only a tiny part of the file is in my download folder. The file I am trying to download in the example is 2MB, the file in my folder is only 4kb and it won't open. I haven't even gotten to cksum yet, but of course it would fail. I've tried other Sharepoint download links (like .linkingUrl and .linkingUri), but I get the same result. When I paste the url the way I have constructed it above into my browser, the file downloads just fine.
Edit: The file is actually an HTML file. It looks like this:
<html><head><title>Working...</title>
</head><body><form method="POST" name="hiddenform" action="https://keysighttech.sharepoint.com/_forms/default.aspx">
<input type="hidden" name="code" value="..." />
<input type="hidden" name="id_token" value= "..."/>
<input type="hidden" name="session_state" value= "..." />
<input type="hidden" name="correlation_id" value="..."/>
<noscript><p>Script is disabled. Click Submit to continue.</p>
<input type="submit" value="Submit" /></noscript></form>
<script language="javascript">document.forms[0].submit();</script></body></html>
How can I proceed with the download? Any suggestions?
Thank you in advance!
I figured it out. Basically, the UrlDownloadToFile routine does not pass any authentication along with it. So when I send a request for a file, either I get a 401 Unauthorized, an error which basically just spits my request back to me, or the "hint" i posted above, which basically is a redirect with all of the tenant and authentication methods. So instead, I went ahead get authorized and included the headers that I usually use with standard Sharepoint API requests and it returned the file to me in a bit stream. The final class function looks something like this:
Dim url As String
Dim filePtr As Long
Dim oResp() As Byte 'byte array to store the response object
Dim reqObj As Object
'make sure we can navigate to the right folder on people's computers
Dim userPath As String
Dim filePath As String
Dim wshShell As Object
Dim reqKey() As String
Dim reqVal() As String
'Get the windows shell version for special folders
Set wshShell = CreateObject("WScript.Shell")
'get the documents folder for this computer
userPath = wshShell.SpecialFolders("MyDocuments")
filePath = userPath & SHAREPOINT_TEMP_FOLDER
'Check if the 'SharepointTemp' folder exists
'if not, create the directory
If Dir(filePath, vbDirectory) = "" Then MkDir (filePath)
reqKey = sharepointHeadersKeys
reqVal = sharepointHeadersVals
'Extract the site (this can differ based on the connected app)
url = relativeUrl & SHAREPOINT_BINARY_REQUEST
Set reqObj = getRequest(url, bearer:=AuthToken.item("access_token"), key:=reqKey, value:=reqVal, blnAsync:=True)
'now the file should be in reqObj
oResp = reqObj.responseBody
'Create a local file and save the results
filePtr = FreeFile
Debug.Print "Downloading to: " & filePath & fileName
If Dir(filePath & fileName) <> "" Then Kill filePath & fileName
Open filePath & fileName For Binary As #filePtr
Put #filePtr, , oResp
Close #filePtr
Now I can use the file from my temp folder as I was before. I am using the metadata.uri returned from the API call and associated with the file object that I queried. This seems to me to be the easiest and cleanest way to do it - especially because I can search the file binary if I am looking for specific text or keywords and save the overhead of opening the file at all. But, of course, I am open to other methods and suggestions.
How can I get the byte array of the opened Word Document (.docm) without saving it to a local drive first.
The document will be opened on a Thin Client without any local drive from SharePoint. When the user want to save the changes, I need to send the byte array to a web-service to process it. (Not back to SharePoint).
Dim filePath As String
Dim fileName As String
Dim fullFileName As String
filePath = ThisDocument.path
fileName = ThisDocument.Name
fullFileName = filePath + "/" + fileName
the value of filePath is 'http://webiste/application'
the value of fileName is 'theOpenFileName.docm'
the value of fullFileName is 'http://webiste/application/theOpenFileName.docm'
How can I get the whole file as a byte array so I can send it to the web-service like this:
Dim bytFile() As Byte
Dim http
Dim userName As String
Dim url As String
Set http = CreateObject("MSXML2.ServerXMLHTTP")
userName = "Me"
'--- read file
bytFile = ??????????
'--- send the file to the API server
url = "http://localhost/DocWebApi/Post?fileName=" & fileName & "&userName=" & userName
http.Open "POST", url, False
http.Send (bytFile)
http.waitForResponse 4000
Thanks in advance!
Try the next approach, please:
Sub testByteArray()
Dim bytFile() As Byte, strDocShare As String
Dim fileDoc As Integer: fileDoc = FreeFile
strDocShare = Application.GetOpenFilename("Office Documents (*.docm),*.docm", , "Please select document to be processed...")
If strDocShare = False Then Exit Sub 'If no document has been selected
Open strDocShare For Binary Access Read As #fileDoc
ReDim bytFile(0 To LOF(fileDoc) - 1)
Get #fileDoc, , bytFile
Close #fileDoc
End Sub
If the document will be open, the above code may return an error. A method to determine if a shared document/workbook is open by other user, uses some similar code and catches the error...
I have an Excel workbook that has an active data connection to a SharePoint list on a company server. The SP list is just a listing of all the files in an SP document library at that point in time. I have a VBA subroutine that is responsible for refreshing this data connection to see what is in the library at that time and then move some info from the list (document name, document author, submission timestamp, etc.) to a different workbook.
The SharePoint site uses Active Directory credentials to authenticate and the SharePoint is also mapped as a network drive on the PC running the code. But even so, refreshing this data connection sometimes results in a credential prompt that looks just like the image at the end of my post. If I manually enter the same AD credentials again, the connection request is authenticated and the list updates in Excel.
My question is this: how can I account for this in my code? Ideally, I would like for this to trigger an email alert or something, but the thing is that the line of code (ThisWorkbook.RefreshAll) that performs the connection refresh does not run to completion until the credential prompt is dealt with, so I can't set up any handlers in the lines of code that follow. I can't have this refresh potentially resulting in code that just hangs on this line until someone happens to notice something is wrong (it is running on an unattended PC). Anyone know anything that could help deal with my issue?
Since the drive is locally mapped, you should be able to just go directly to the file and manipulate it however you need, importing it, instead of having an active data connection. It would allow you more flexibility than a more rigid data connection.
This website has a good example showing how to do what you're looking for, but the way I'm imagining would be more efficient considering the circumstances.
This really depends on how you are doing your connection and in some instances it is not possible, but you can append Username and Password to a URL to pass your credentials, such as defined here (for other languages but you get the gist):
https://www.connectionstrings.com/sharepoint/
Now the reality is, you probably aren't doing a REST connection and you might have to as discussed here: https://www.experts-exchange.com/questions/28628642/Excel-VBA-code-using-authentication-to-SharePoint.html
They recommended:
Public Sub CopyToSharePoint()
On Error GoTo err_Copy
Dim xmlhttp
Dim sharepointUrl
Dim sharepointFileName
Dim tsIn
Dim sBody
Dim LlFileLength As Long
Dim Lvarbin() As Byte
Dim LobjXML As Object
Dim LstrFileName As String
Dim LvarBinData As Variant
Dim PstrFullfileName As String
Dim PstrTargetURL As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim fldr As Folder
Dim f As File
Dim pw As String
Dim UserName As String
Dim RetVal
Dim I As Integer
Dim totFiles As Integer
Dim Start As Date, Finish As Date
UserName = InputBox(Username?") pw = InputBox("Password?")
sharepointUrl = "[http path to server]/[server folder to write to]"
Set LobjXML = CreateObject("Microsoft.XMLHTTP")
Set fldr = fso.GetFolder(CurrentProject.Path & "\[folder with files to
upload]\") totFiles = fldr.Files.Count
For Each f In fldr.Files
sharepointFileName = sharepointUrl & f.Name
'**************************** Upload text files
**************************************************
If Not sharepointFileName Like "*.gif" And Not sharepointFileName
Like "*.xls" And Not sharepointFileName Like "*.mpp" Then
Set tsIn = f.OpenAsTextStream
sBody = tsIn.ReadAll
tsIn.Close
Set xmlhttp = CreateObject("MSXML2.XMLHTTP.4.0")
xmlhttp.Open "PUT", sharepointFileName, False, UserName, Password
xmlhttp.Send sBody
Else
'**************************** Upload binary files
**************************************************
PstrFullfileName = CurrentProject.Path & "\[folder with files to upload]\" & f.Name
LlFileLength = FileLen(PstrFullfileName) - 1
' Read the file into a byte array.
ReDim Lvarbin(LlFileLength)
Open PstrFullfileName For Binary As #1
Get #1, , Lvarbin
Close #1
' Convert to variant to PUT.
LvarBinData = Lvarbin
PstrTargetURL = sharepointUrl & f.Name
' Put the data to the server, false means synchronous.
LobjXML.Open "PUT", PstrTargetURL, False, Username, Password
' Send the file in.
LobjXML.Send LvarBinData
End If
I = I + 1 RetVal = SysCmd(acSysCmdSetStatus, "File " & I & " of " & totFiles & " copied...") Next f
RetVal = SysCmd(acSysCmdClearStatus) Set LobjXML = Nothing Set
fso = Nothing
err_Copy: If Err <> 0 Then MsgBox Err & " " & Err.Description End If
End Sub
Realistically, I think this answer may get you going down the right road: https://sharepoint.stackexchange.com/questions/255264/sharepoint-api-and-vba-access-denied
Regardless, this is a problem and good luck. I had better luck using MS Access to link the list as a table and then using Excel to just call Access and get what I needed.
Private Sub cmdSyncSP_Click()
On Error GoTo ErrorCode
Application.Cursor = xlWait
Dim app As New Access.Application
'Set app = CreateObject("Application.Access")
app.OpenCurrentDatabase Application.ActiveWorkbook.Path & "\SP_Sync.accdb"
app.Visible = False
app.Run "doManualCheck"
app.CloseCurrentDatabase
Set app = Nothing
MsgBox "Sync has finished. Refresh and proceed to copy your data.", vbInformation + vbOKOnly, "Success"
ExitCode:
On Error Resume Next
Application.Cursor = xlDefault
Exit Sub
ErrorCode:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Sync Error"
Resume ExitCode
End Sub
There is a ZIP data file at http://portal.flmmis.com/FLPublic/Provider_ManagedCare/Provider_ManagedCare_Registration/tabId/77/Default.aspx?linkid=pmlwhich contains a CSV that I need to utilize in my Access database.
This file is updated daily which is why the process needs to be automated. After extracting the CSV from the ZIP file into an Excel file, I need to replace all commas within the file with a space.
After that I need to import that file into a database titled Network_DB so that I can produce reports based on that and other data sets. It is comma delimited.
I have no idea where to start. I've seen suggestions for Python, PowerShell, Excel macros...the whole nine yards. I'll say that I don't have access to Python at work and I'm unfamiliar with PowerShell.
If you are using MS Access already then VBA is the easiest way to tackle this problem.
To download a file from the web you can use this snippet:
Sub downloadUrl(url As String, destinationFile As String)
Dim htp As New MSXML2.XMLHTTP60
Dim stream As New ADODB.Stream
'Request file
With htp
.Open "GET", url, false
.send
End With
'Save to file
With stream
.Open
.Type = adTypeBinary
.write htp.responseBody
.SaveToFile destinationFile
.Close
End With
End Sub
Then call this function like this
downloadUrl "http://portal.flmmis.com/FLPublic/Provider_ManagedCare/Provider_ManagedCare_Registration/tabId/77/Default.aspx?linkid=pml", "C:\Users\Public\test.csv"
To import a CSV to MS Access you can use one of the import wizards to help you.
Ps.: I tried to access the provided link but it seems to be offline for me
You can use the DownLoadFile function here:
Show pictures directly from URLs in Access forms and reports
to download the file. Then unzip it using a function like this:
Public Function UnzipFile( _
ByVal ZipFile As String, _
Optional ByRef DestinationFolder As String) _
As Boolean
Const LocalAppData As String = "LOCALAPPDATA"
Const OverWriteAll As Long = &H10&
Dim ShellApp As Object
Dim FileName As String
Dim Result As Boolean
' Any error will cause a return value of False.
On Error Resume Next
FileName = Dir(ZipFile, vbNormal)
If InStr(StrReverse(ZipFile), StrReverse(FileName)) = 1 Then
' ZipFile exists.
If DestinationFolder = "" Then
' Find and use user's LocalAppData folder, and return constructed folder name.
DestinationFolder = Environ(LocalAppData) & "\" & Left(FileName, InStr(FileName, ".")) & "Files"
End If
If Dir(DestinationFolder, vbDirectory) = "" Then
' Create new destination folder.
MkDir DestinationFolder
End If
If InStr(StrReverse(DestinationFolder), StrReverse(Dir(DestinationFolder, vbDirectory))) = 1 Then
' Destination folder existed or has been created successfully.
Set ShellApp = CreateObject("Shell.Application")
' Unzip files to destination folder.
ShellApp.Namespace(CVar(DestinationFolder)).CopyHere ShellApp.Namespace(CVar(ZipFile)).Items, OverWriteAll
If Err.Number = 0 Then
Result = True
End If
End If
End If
UnzipFile = Result
Set ShellApp = Nothing
End Function
We have been using VBA code for years with Excel 2003. I have about 70 files that I pull information from and compile it into one spreadsheet. This time, it only recognizes 3 of the 70. I do not get any errors. I noticed that all 3 recognized are the old version ".xls." and all not being recognized are the ".xlsx". The portion of the code that I think is causing the problem is below. Can anyone help?
Public currApp As String
Public i As String
Public recordC As String
Public excelI As Integer
Public intFileHandle As Integer
Public strRETP As String
Public errFile As String
Public Function loopFiles(ByVal sFolder As String, ByVal noI As Integer)
'This function will loop through all files in the selected folder
'to make sure that they are all of excel type
Dim FOLDER, files, file, FSO As Object
excelI = noI
'MsgBox excelI
i = 0
'Dim writeFile As Object
'writeFile = My.Computer.FileSystem.WriteAllText("D:\Test\test.txt", "sdgdfgds", False)
Dim cnn As Connection
Set cnn = New ADODB.Connection
currApp = ActiveWorkbook.path
errFile = currApp & "\errorFile.txt"
If emptyFile.FileExists(errFile) Then
Kill errFile
Else
'Do Nothing
End If
'cnn.Open "DSN=AUTOLIV"
'cnn.Open "D:\Work\Projects\Autoliv\Tax workshop\Tax Schedules\sox_questionnaire.mdb"
cnn.Open ("DRIVER={Microsoft Access Driver (*.mdb)}; DBQ=" & currApp & "\tax_questionnaire.mdb")
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Set FSO = CreateObject("Scripting.FileSystemObject")
'Upon each found excel file it will make a call to saveFiles.
If sFolder <> "" Then
Set FOLDER = FSO.getfolder(sFolder)
Set files = FOLDER.files
For Each file In files
'ONLY WORK WITH EXCEL FILES
If file.Type = "Microsoft Excel Worksheet" Then
Workbooks.Open fileName:=file.path
xlsx is a "macro-free" workbook. To use VBA in the new file format, the file must be saved as an xlsm file.
EDIT: I read the question too hastily. If you want to identify excel files from the FSO object, use file.Type LIKE "Microsoft Excel *" or similar. Or, check the file's extension against ".xls*"
EDIT
The whole concept of identifying the file type by looking at the file name is fundamentally flawed. It's too easily broken by changes to file extensions and/or the "type" texts associated with those descriptions. It's easily broken by, say, an image file named "file.xls". I would just try opening the file with Workbooks.Open and catch the error. I'd probably put this logic in a separate function:
Function OpenWorkbook(strPath As String) As Workbook
On Error GoTo ErrorLabel
Set OpenWorkbook = Workbooks.Open(strPath)
ExitLabel:
Exit Function
ErrorLabel:
If Err.Number = 1004 Then
Resume ExitLabel
Else
'other error handling code here
Resume ExitLabel
End If
End Function
Then you can consume the function like this:
Dim w As Workbook
Set w = OpenWorkbook(file.Path)
If Not (w Is Nothing) Then
'...
The problem you're having has to do with this line:
If file.Type = "Microsoft Excel Worksheet" Then
Try adding and replacing it with this:
// add these lines just AFTER the line 'For Each file In files'
IsXLFile = False
FilePath = file.path
FilePath2 = Right(FilePath, 5)
FilePath3 = Mid(FilePath2, InStr(1, FilePath2, ".") + 1)
If UCase(Left(FilePath3, 2)) = "XL" Then IsXLFile = True
// replace faulty line with this line
If IsXLFile = True Then
Let me know how it works. Yes, it'd be possible to compress the statements that start with FilePath into one expression but I left it like that for clarity. Vote and accept the answer if good and follow-up if not.
Have a nice day.