Hi All,
I’m fairly new to this but i seem to be having issues. I’m trying to search and download a document using the Companies House API via Excel VBA.
Below is the code I’m using.
Sub DownloadStatementOfAffairs()
Dim companyNumber As String
Dim apiKey As String
Dim filingUrl As String
Dim downloadUrl As String
Dim jsonResponse As String
Dim documentID As String
Dim request As Object
Dim json As Object
Dim item As Object
Dim filename As String
Dim downloadRequest As Object
Dim downloadStream As Object
Dim descriptionText As String
' Set your API key here
apiKey = "Redacted"
' Get the company number from cell A2
companyNumber = ThisWorkbook.Sheets(1).Range("A2").Value
' API URL to get the filing history
filingUrl = "https://api.company-information.service.gov.uk/company/" & companyNumber & "/filing-history"
' Debug: Print the URL for filing history
Debug.Print "Filing URL: " & filingUrl
' Create the XML HTTP request to get filing history
Set request = CreateObject("MSXML2.XMLHTTP")
request.Open "GET", filingUrl, False
request.setRequestHeader "Authorization", "Basic " & Base64Encode(apiKey & ":")
request.send
' Parse JSON response
Set json = JsonConverter.ParseJson(request.responseText)
' Debugging output: Loop through items to see descriptions
Debug.Print "Filing history items for company " & companyNumber & ":"
For Each item In json("items")
Debug.Print item("description") ' Print each description in the Immediate Window
Next item
' Find the "Statement of Affairs" document ID
documentID = “”
For Each item In json(“items”)
descriptionText = LCase(item(“description”))
If InStr(1, descriptionText, “statement-of-affairs”, vbTextCompare) > 0 Then
documentID = Replace(item(“links”)(“document_metadata”), “https://document-api.company-information.service.gov.uk”, “”)
Exit For
End If
Next item
If documentID = “” Then
MsgBox “Statement of Affairs not found in filing history.”, vbExclamation
Exit Sub
End If
’ Construct the download URL for the document
downloadUrl = “https://document-api.company-information.service.gov.uk” & documentID & “/content”
’ Debug: Print the download URL
Debug.Print "Download URL: " & downloadUrl
' Create the XML HTTP request to download the document
Set downloadRequest = CreateObject("MSXML2.XMLHTTP")
downloadRequest.Open "GET", downloadUrl, False
downloadRequest.setRequestHeader "Authorization", "Basic " & Base64Encode(apiKey & ":")
' Debugging: Print Authorization Header
Debug.Print "Authorization Header: Basic " & Base64Encode(apiKey & ":")
' Error handling for the send request
On Error Resume Next
downloadRequest.send
If Err.Number <> 0 Then
MsgBox "Error sending request: " & Err.Description, vbExclamation
Exit Sub
End If
On Error GoTo 0
' Check if the document was found and downloaded
If downloadRequest.Status = 200 Then
' Save the document as a PDF
filename = ThisWorkbook.Path & "\Statement_of_Affairs_" & companyNumber & ".pdf"
Set downloadStream = CreateObject("ADODB.Stream")
downloadStream.Type = 1 ' Binary
downloadStream.Open
downloadStream.Write downloadRequest.responseBody
downloadStream.SaveToFile filename, 2 ' Overwrite
downloadStream.Close
MsgBox "Document downloaded successfully: " & filename, vbInformation
Else
MsgBox "Failed to download the document.", vbExclamation
End If
End Sub
’ Helper function to encode API key in Base64
Function Base64Encode(text As String) As String
Dim arr() As Byte
arr = StrConv(text, vbFromUnicode)
Dim objXML As Object
Dim objNode As Object
Set objXML = CreateObject(“MSXML2.DOMDocument”)
Set objNode = objXML.createElement(“b64”)
objNode.DataType = “bin.base64”
objNode.nodeTypedValue = arr
Base64Encode = Replace(objNode.text, vbLf, “”)
End Function
When i run the macro i get the error “Error sending request: Accessed is denied” I’m pretty sure my API key is okay and i think i should have access. Could someone assist?
Cheers
Paul
