In MS Access VBA , I want to download file from link on internet ,
in Windows 10 x64 these functions work correctly with no error, but it encounters an error in Window 7 x64
in the below code on objXMLHTTP.send I get this error :
Run-time error '-2146697211 (800c0005)': The system cannot locate the
resource specified
Sub DownloadFile(URL As String, LocalFile As String)
Dim objXMLHTTP As Object
Set objXMLHTTP = CreateObject("MSXML2.XMLHTTP")
objXMLHTTP.Open "GET", URL, False
objXMLHTTP.send
If objXMLHTTP.Status = 200 Then
Set objADOStream = CreateObject("ADODB.Stream")
objADOStream.Open
objADOStream.Type = 1 'adTypeBinary
objADOStream.Write objXMLHTTP.ResponseBody
objADOStream.SaveToFile LocalFile, 2 'adSaveCreateOverWrite
objADOStream.Close
Set objADOStream = Nothing
End If
Set objXMLHTTP = Nothing
End Sub
Private Sub Form_Open(Cancel As Integer)
Call DownloadFile("https://ghaemcoarsh.com/APPY/BMH.exe", "C:\Users\Administrator\Desktop\test\BMH.exe")
End Sub
the point is my code works on Windows 10 but it only error on Windows 7
Related
I'm currently working on an excel table that reads various API's and processes the results.
I'm trying to adapt an api request for this table, but unfortunately I can't do it.
I'm assuming this good working code:
Public Sub Main()
On Error Resume Next
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "https://api.binance.com/api/v3/ticker/price", False
On Error Resume Next
http.Send
On Error GoTo error
Set json = ParseJson(http.ResponseText)
i = 10
For Each Item In json
If Item("symbol") = Workbooks(1).Worksheets("Tabelle1").Range("A1").Value And Workbooks(1).Worksheets("Tabelle1").Range("A1").Value <> "" Then
Sheets(1).Cells(1, i).Value = Item("price")
i = i + 1
End If
Next
Exit Sub
error:
End Sub
CELL A1 says: ETHBTC and I get the corresponding value in J1
Unfortunately, the following code doesn't work and I don't understand why:
Sub GetVolume()
On Error Resume Next
'List of all symbols
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", "https://api.coincap.io/v2/candles", False
On Error Resume Next
http.Send
Set json = ParseJson(http.ResponseText)
i = 10
For Each Item In json("data")
If Item("exchange") = Workbooks(1).Worksheets("Tabelle1").Range("A1").Value And Workbooks(1).Worksheets("Tabelle1").Range("A1").Value <> "" Then
Sheets(1).Cells(1, i).Value = Item("volume")
i = i + 1
End If
Next
Exit Sub
error:
End Sub
In this case, the content of cell A1 looks like this:
binance&interval=m5&baseId=monero"eId=bitcoin&start=1649894400000&end=1649898000000
The request for this looks like this:
https://api.coincap.io/v2/candles?exchange=poloniex&interval=h1&baseId=ethereum"eId=bitcoin&start=1649894400000&end=1649898000000
I would be very grateful for a tip
I've tried different combinations, but get no answer
"https://api.coincap.io/v2/candles" HTTPRequest.responseText:
"{"error":"missing quote","timestamp":1672666785053}"
The code is returning an missing quote error, caused by missing query parameters.
CoinCap Docs has a query builder that you can use. Start with a working query and than start modifying parameters until it fits your specifications.
I recommend creating a function to handle returning the json data. This simplifies development by making it easier to test the code.
Function QueryCoinCap(URL As String) As Object
On Error GoTo QueryCoinCap_Error
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, False
.Send
Set QueryCoinCap = ParseJson(.ResponseText)
End With
On Error GoTo 0
Exit Function
QueryCoinCap_Error:
Rem CoinCap was unable to process the request
Rem to simplify the error handle I'll create a Scripting.Dictionary and ADD A CUSTOM ERROR TO IT
Rem This allows us to treat all errors in the same way
Dim Dictionary As Object
Set Dictionary = CreateObject("Scripting.Dictionary")
Dictionary("error") = "CoinCap was unable to process the request"
Set QueryCoinCap = Dictionary
End Function
Sub WorkingExampleQueryCoinCap()
Dim URL As String
URL = "https://api.coincap.io/v2/assets"
Dim JsonDictionary As Object
Set JsonDictionary = QueryCoinCap(URL)
If JsonDictionary.Exists("error") Then
Debug.Print JsonDictionary("error")
Else
Stop
Rem Do Something
End If
End Sub
Sub ErrorExampleQueryCoinCap()
Dim URL As String
URL = "https://api.coincap.io/v2/candles"
Dim JsonDictionary As Object
Set JsonDictionary = QueryCoinCap(URL)
If JsonDictionary.Exists("error") Then
Debug.Print JsonDictionary("error")
Else
Rem Do Something
End If
End Sub
I wanted to open the CR, while clicking a button on the form in VB 6.0. This is the code i've used:
CrystalReport1.ReportFileName = "D:\VISUAL BASIC\monrep.rpt"
CrystalReport1.RetrieveDataFiles
CrystalReport1.Action = 1
But when I try to execute i ran into "Cannot open SQL server" error. But I've used Access as the database file. I wanted only to open the CR Showing the contents of a particular table. I'm using CR 8.5. Can anyone help me regarding this?
This may Help you
Public Sub OpenReport(ReportPath As String, DataPath As String)
' 1) add a reference to the Crystal Reports 8.5 ActiveX Designer Run Time Library
' 2) place a CrystalActiveXReportViewer control named crView to your form
Dim oCRapp As CRAXDRT.Application
Dim oReport As CRAXDRT.Report
Set oCRapp = New CRAXDRT.Application
Set oReport = oCRapp.OpenReport(ReportPath, crOpenReportByTempCopy)
SetReportDatabase oReport, DataPath
crView.ReportSource = oReport
crView.ViewReport
End Sub
Public Sub SetReportDatabase(CrystalRpt As CRAXDRT.Report, DataPath As String)
Dim oTab As CRAXDRT.DatabaseTable
On Error GoTo errhndl
For Each oTab In CrystalRpt.Database.Tables
' check connection type
If LCase$(oTab.DllName) = "crdb_odbc.dll" Then
With oTab.ConnectionProperties
.DeleteAll
.Add "Connection String", "Driver={Microsoft Access Driver (*.mdb, *.accdb)};Dbq=" & DataPath & ";Uid=Admin;Pwd=MyPassword"
End With
End If
Next oTab
' subreports
Dim rptObj As Object, rptObjs As CRAXDRT.ReportObjects, rptSecs As CRAXDRT.Sections, rptSec As CRAXDRT.Section
Dim subRptObj As CRAXDRT.SubreportObject, oSubTab As CRAXDRT.DatabaseTable
Dim subRpt As CRAXDRT.Report
Set rptSecs = CrystalRpt.Sections
For Each rptSec In rptSecs
Set rptObjs = rptSec.ReportObjects
For Each rptObj In rptObjs
If rptObj.Kind = crSubreportObject Then
Set subRptObj = rptObj
Set subRpt = subRptObj.OpenSubreport
For Each oSubTab In subRpt.Database.Tables
If oSubTab.DllName = "crdb_odbc.dll" Then
With oSubTab.ConnectionProperties
.DeleteAll
.Add "Connection String", "Driver={Microsoft Access Driver (*.mdb, *.accdb)};Dbq=" & DataPath & ";Uid=Admin;Pwd=MyPassword"
End With
End If
Next oSubTab
End If
Next rptObj
Next rptSec
Exit Sub
errhndl:
Err.Raise Err.Number, "SetReportDatabase", Err.Description
End Sub
I have a legacy vba program that am trying to implement an software update functionality for. This will require me to copy the update from a location on our site and save temporary on the user system.
I have implemented the updater on the desktop but am having issue copying the patch from our site. I have tried some suggestion to use \oursite.com\folder\file.txt for example, but this has not worked for me as it is saying file not found.
downloadPaths(0) = "\\oursite.com\foldername\update\test.txt"
'once we have our folder in place, we will download the current update
' and save in the current local folder
If (IsArray(downloadPaths)) Then
' we will loop over each download patches to get from source
For Each updatepath In downloadPaths
If (updatepath <> "") Then
If (fs.FileExists(updatepath)) Then
' do whatever here
end if
end if
next
end if
Well as nobody attempt to answer this question, I have decided to post the solution I came up with. It is dirty, but it does get the job done, and the software update functionality is completed. Please note that in validating successful download, the response to check for will be determine by your server. I use Apache, Mysql, and Php 5 >.
Public Function downloadFileFromUrl(sourceUrl As Variant, destinationPath As Variant) As Boolean
On Error GoTo downloadFileFromUrlError
Dim validFile As Boolean
'It takes a url (sourceUrl) and downloads the URL to destinationPath.
With New WinHttpRequest
'Open a request to our source
.Open "GET", sourceUrl
'Set this to get it to go through the firewall
.SetAutoLogonPolicy AutoLogonPolicy_Always
.SetProxy 2, "http://127.0.0.1:8888", "*.never"
.SetRequestHeader "Accept", "*/*"
'Set any options you may need http://msdn.microsoft.com/en-us/library/windows/desktop/aa384108(v=vs.85).aspx
'Set a custom useragent, not needed, but could be useful if there are problems on the server
.Option(WinHttpRequestOption_UserAgentString) = "Mozilla/4.0 (compatible; VBA Wget)"
'Automatically follow any redirects
.Option(WinHttpRequestOption_EnableRedirects) = "True"
.Send
' check if the download is a valid file before we write to file
If (isValidFileDownload(.responseText)) Then
'Write the responseBody to a file
Dim ado As New ADODB.Stream
ado.Type = adTypeBinary
ado.Open
ado.Write .ResponseBody
ado.SaveToFile destinationPath, adSaveCreateOverWrite
ado.Close
downloadFileFromUrl = True 'download was successful
Else
downloadFileFromUrl = False 'download was not successful
End If
End With
downloadFileFromUrlExit:
On Error Resume Next
Set ado = Nothing
Exit Function
downloadFileFromUrlError:
downloadFileFromUrl = False 'An error occurred
Select Case Err
Case Else
Debug.Print "Unhandled Error", Err.Number, Err.description, Err.Source, Erl()
End Select
Resume downloadFileFromUrlExit
Resume
End Function
Private Function isValidFileDownload(responseText As Variant) As Boolean
On Error Resume Next
If (InStr(1, left(responseText, 1000), "<h1>Object not found!</h1>")) Then
Exit Function
Else
isValidFileDownload = True
End If
End Function
From MS Access I am generating several MS Access Workbooks. Via the following code I am getting the desired save location for all of the workbooks. The following code was working without issues a few days ago. Now it abruptly fails with no error number. MS Access crashes and I get a prompt to restart MS Access and a backup file is automatically created of the MS Access project I am working on.
Strangely the code works fine if I step through it with the debugger. It simply is not working at full speed.
UPDATE 1:
If I do the falling the save_location call works.
Private Sub make_report()
' TODO#: Change to late binding when working
Dim strSaveLocation as string
Dim xl as Excel.Application
dim wb as Excel.Workbook
strSaveLocation = save_location("G:\Group2\Dev\z_report")
Set xl=New Excel.Application
' do workbook stuff
With xl
strSaveLocation = strSaveLocation & "\report_name.xlsx"
wb.SaveAs strSavelLocation, xlOpenXMLWorkbook
End With ' xl
Set xl=nothing
End Sub
If I call the save_location function like this it abruptly crashes MS Access. It doesn't throw an error or anything. It just crashes.
Private Sub make_report()
' TODO#: Change to late binding when working
Dim strSaveLocation as string
Dim xl as Excel.Application
dim wb as Excel.Workbook
Set xl=New Excel.Application
' do workbook stuff
With xl
' the call to save_location is inside of the xl procedure
strSaveLocation = save_location("G:\Group2\Dev\z_report")
strSaveLocation = strSaveLocation & "\report_name.xlsx"
wb.SaveAs strSavelLocation, xlOpenXMLWorkbook
End With ' xl
Set xl=nothing
End Sub
By moving the save_location call inside the Excel.Application work string it fails. I don't understand why.
Private Function save_location(Optional ByVal initialDir As String) As String
On Error GoTo err_trap
Dim fDialog As Object
Dim blMatchIniDir As Boolean
Set fDialog = Application.FileDialog(4) ' msoFileDialogFolderPicker
With fDialog
.Title = "Select Save Location"
If NOT (initialDir=vbnullstring) then
.InitialFileName = initialDir
End If
If .Show = -1 Then
' item selected
save_location = .SelectedItems(1)
End If
End With
Set fDialog = Nothing
exit_function:
Exit Function
err_trap:
Select Case Err.Number
Case Else
Debug.Print Err.Number, Err.Description
Stop
Resume
End Select
End Function
Actions tried:
Decompile project and recompile
Create new MS Access project and import all objects
Compact and repair
Reset all reference
Notes:
I am using the client's system and
I don't know of any system updates
Client's system is a virtual desktop via VMWare
Office 2013
Windows 7 Pro
while i am not sure if this is the specific problem - but if it is the case, it messes with anything VBA. Check the folder names and file names for any apostrophes. While windows allows this, an apostrophe will be seen in VBA as a comment, and will crash it. Have the client walk you through the exact file that he selects to confirm there is no apostrophe character in the filename or folder name.
How do you access the Application Icon path in MS Access 2003 programmatically?
It's a custom property ("AppIcon") of the database object.
Set dbs = CurrentDb
sAppIconPath = dbs.Properties("AppIcon")
Note - you will get an error if the property doesn;t exist.
This code from the Access Help shows how to create the property:
Example
The following example shows how to change the AppIcon and AppTitle properties in a Microsoft Access database (.mdb). If the properties haven't already been set or created, you must create them and append them to the Properties collection by using the CreateProperty method.
Sub cmdAddProp_Click()
Dim intX As Integer
Const DB_Text As Long = 10
intX = AddAppProperty("AppTitle", DB_Text, "My Custom Application")
intX = AddAppProperty("AppIcon", DB_Text, "C:\Windows\Cars.bmp")
CurrentDb.Properties("UseAppIconForFrmRpt") = 1
Application.RefreshTitleBar
End Sub
Function AddAppProperty(strName As String, _
varType As Variant, varValue As Variant) As Integer
Dim dbs As Object, prp As Variant
Const conPropNotFoundError = 3270
Set dbs = CurrentDb
On Error GoTo AddProp_Err
dbs.Properties(strName) = varValue
AddAppProperty = True
AddProp_Bye:
Exit Function
AddProp_Err:
If Err = conPropNotFoundError Then
Set prp = dbs.CreateProperty(strName, varType, varValue)
dbs.Properties.Append prp
Resume
Else
AddAppProperty = False
Resume AddProp_Bye
End If
End Function