I am trying to download a file from the internet and I am getting this error code: -2147467260. The location can be accessed with no issues from IE. This is the code I am using:
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
Function DownloadFile(URL As String, LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadFile = True
End Function
Apparently, the error number means Operation Aborted or Transaction aborted.
The second link is a question here at Stack Overflow and the answer says that it works when you run the program as admin.
So there are two things that you can try:
Run as admin, like mentioned before
Try a different file (to be sure). For example, I'm on Windows 7 right now, my user has admin privileges and I just successfully downloaded this file with the code from your question.
The problem was with the filename. I am generating filenames from an Access Database and the table was adding trailing spaces. I am investing where these trailing spaces came from.
Related
I tried to follow up with the topic here:
How to connect to OPEN workbook in another instance of Excel
But I ran into a problem,
I am not able grab the new instance name or path.
However I know I have open Excel window in another instance (opened from a SAP system) and when I open VBA editor in that SAP generated Excel file and I type: ? Thisworkbook.Path in immediate window I get nothing, no path is given and thus this solutions does not get the instance path.
What can I do to make it work ?
My issue is that this: Set xlApp = GetObject("C:\Tmp\TestData2.xlsx") is not grabbing the workbook name (including This.workbook.name or activeworkbook.name)
Any idea how else I can make VBA code in instance 1 work with workbook in instance 2?
I only want to save it nothing more, I'm using Saveas option, or at least I try.
Have anyone had a similar issue?
Working with the Excel files downloaded from SAP is always problematic.
You can use the module below and add before the xls.Close SaveChanges:=False this line xls.SaveAs Filename:='Any name that you want after that just place a call in your code after downloading the Excel File with
Call Close_SAP_Excel("TestData2.xlsx")
And it should work fine.
Module:
#If VBA7 Then
Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "oleacc" ( _
ByVal hwnd As LongPtr, ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
Private Declare PtrSafe Function FindWindowExA Lib "user32" ( _
ByVal hwndParent As LongPtr, ByVal hwndChildAfter As LongPtr, _
ByVal lpszClass As String, ByVal lpszWindow As String) As LongPtr
#Else
Private Declare Function AccessibleObjectFromWindow Lib "oleacc" ( _
ByVal hwnd As Long, ByVal dwId As Long, riid As Any, ppvObject As Object) As Long
Private Declare Function FindWindowExA Lib "user32" ( _
ByVal hwndParent As Long, ByVal hwndChildAfter As Long, _
ByVal lpszClass As String, ByVal lpszWindow As String) As Long
#End If
Sub Close_SAP_Excel(ParamArray FileNames())
'Procedure to close files downloaded from SAP and at the same time close the Excel application instance that will be open with them.
Dim ExcelAppSAP As Variant
Dim ExcelFile As Variant
Dim FinishedLoop As Boolean, TimeoutReached As Boolean, FileClosed As Boolean
Dim ReTry As Long
Dim i As Long, x As Long
Set ExcelAppSAP = Nothing
ReTry = 100000 'Used as Timeout 100000 = ~10 seconds
i = 1
'The following loop is executed until excel file is closed.
'Inside of this, there is a For Loop for each Excel Instance and inside of that is another loop
'for each excel inside the instance. If name matches, it is closed.
Do While Not FinishedLoop
If i > ReTry Then
TimeoutReached = True
Exit Do
End If
For Each ExcelFile In GetExcelInstances() 'Function to Get Excel Open Instances
For Each xls In ExcelFile.Workbooks
For x = LBound(FileNames()) To UBound(FileNames())
If xls.Name = FileNames(x) Then
Set ExcelAppSAP = ExcelFile 'Set Instance opened by SAP to variable
'Here add actions if needed. Reference to workbook as xls e.g.: xls.Sheets(1).Range("A1").Copy
xls.Close SaveChanges:=False
FileClosed = True
End If
Next x
Next
Next
If FileClosed Then
FinishedLoop = True
End If
i = i + 1
Loop
ThisWorkbook.Activate
If Not TimeoutReached Then
If FileClosed Then
On Error Resume Next
If ExcelAppSAP.Workbooks.Count = 0 Then
ExcelAppSAP.Quit
End If
Else
MsgBox "Excel application instance from SAP was not closed correctly. Please close it manually or try again.", , "Error"
End If
Else
MsgBox "Max timeout reached", , "Error"
End If
End Sub
Public Function GetExcelInstances() As Collection
Dim guid&(0 To 3), acc As Object, hwnd, hwnd2, hwnd3
guid(0) = &H20400
guid(1) = &H0
guid(2) = &HC0
guid(3) = &H46000000
Set GetExcelInstances = New Collection
Do
hwnd = FindWindowExA(0, hwnd, "XLMAIN", vbNullString)
If hwnd = 0 Then Exit Do
hwnd2 = FindWindowExA(hwnd, 0, "XLDESK", vbNullString)
hwnd3 = FindWindowExA(hwnd2, 0, "EXCEL7", vbNullString)
If AccessibleObjectFromWindow(hwnd3, &HFFFFFFF0, guid(0), acc) = 0 Then
GetExcelInstances.Add acc.Application
End If
Loop
End Function
In MSAccess vba, I want to do something like import ShellExecute to open files with their default program.
But I must allow unicode characters in folder or file names (such as Chinese, Korean, Russian, Arabic).
There are good examples of ShellExecute
such as here: https://stackoverflow.com/a/20441268/1518460
or here: https://stackoverflow.com/a/32013971/1518460
And it's good to know to ignore the "?????" in strings in the UI in Access VBA. It makes it look like variables lost the Unicode values but actually the UI can't display Unicode. If the values came direct from the db, they should be fine. (see this).
But paths with Chinese or Korean still won't open, while paths with all ansi will.
I'm trying to use the same declare ShellExecute as in the first example above, taking paths from a linked table in my current Access app:
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal lpnShowCmd As Long) As Long
Private Sub btnLaunchFunVid1_Click()
Dim strFileFolder As String
Dim strFilename As String
Dim strFullFilepath As String
Dim rst As Recordset
Dim qt As String
qt = "select folderPath, filename from ClassAdmin_Videos where rowid = " & CStr(Me.cmbFunVideo1.Value)
Set rst = CurrentDb.OpenRecordset(qt)
strFileFolder = rst.Fields("folderPath")
strFilename = rst.Fields("filename")
strFullFilepath = strFileFolder & strFilename
OpenFunVideoFileWithImportedShellExecute strFullFilepath
End Sub
Public Sub OpenFunVideoFileWithImportedShellExecute(ByVal Path As String)
If Dir(Path) > "" Then
ShellExecute 0, "open", Path, "", "", 0
End If
End Sub
Is there an option I can set to allow Unicode?
Or is there a better function?
Yes, there is a better function.
Note the function you're actually importing: "ShellExecuteA".
Guess what the "A" stand for... it's the ansi version of the function.
There is a "W" == wide == unicode version.
A great basic example can be found here:
http://www.vbforums.com/showthread.php?511136-how-to-use-shellexecute&p=4877907&viewfull=1#post4877907
Using the same in your code would give:
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteW" (ByVal hwnd As Long, ByVal lpOperation As Long, ByVal lpFile As Long, ByVal lpParameters As Long, ByVal lpDirectory As Long, ByVal nShowCmd As Long) As Long
'...
' [no need to change the function getting the path]
'...
Public Sub OpenFunVideoFileWithImportedShellExecute(ByVal Path As String)
If Dir(Path) > "" Then
ShellExecute 0, StrPtr("Open"), StrPtr(Path), 0, 0, 1
End If
End Sub
i'm automating a project where every month i need to go on a website and copy a file from there.
i'm able to copy the file, the problem is that they're named like below so there's no way for me to know which file to copy that month.
filename2015011023549.zip
filename2015021922876.zip
is there a way to get a list of files from a website?
You download the page (see in-line comments) with the file listing to a local file, then parse that file for possible file name candidates:
Option Compare Database
Option Explicit
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
Public Function DownloadFile( _
ByVal strURL As String, _
ByVal strLocalFilename As String) _
As Long
' Download file or page with public access from the web.
' 2004-12-17. Cactus Data ApS, CPH.
' Usage, download a file:
' lngRet = DownloadFile("http://www.databaseadvisors.com/Graphics/conf2002/2002ConferencePicsbySmolin/images/dba02smolin27.jpg", "c:\happybassett.jpg")
'
' Usage, download a page:
' lngRet = DownloadFile("http://www.databaseadvisors.com/conf2002/conf200202.asp", "c:\dbaconference.htm")
' Returns 0 if success, error code if not.
' Error codes:
' -2146697210 "file not found".
' -2146697211 "domain not found".
' Limitation.
' Does not check if local file was created successfully.
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, strURL & vbNullChar, strLocalFilename & vbNullChar, 0, 0)
DownloadFile = lngRetVal
End Function
I've found numerous examples for doing this in several languages, but none that are VBA specific. This question, How to download multiple files in VB6 with progress bar?, addresses three different approaches to do this in VB6.
Use the ASyncRead property of the VB6 UserControl/UserDocument objects
Use type library olelib.tlb and the IBindStatusCallback interface
Use wininet.dll to write your own download to file function
None of these approaches work for me because:
The UserControl/UserDocument objects are not available from VBA
I'd rather not have to maintain and distribute a large external dependency
I did not see an obvious way to get the current file download progress
Number 2 above seemed the most promising. I'm wondering if I can create an IBindStatusCallback interface using a class module from within my VBA project?
Or maybe there are properties/methods available using Number 3 above that would provide the current progress. Any help is much appreciated.
I have done this using the wininet.dll functions. Unfortunately I cannot paste my code as it is owned by my employer.
Use InternetOpen and InternetOpenUrl to start the download, HttpQueryInfoLong to get the content length and then repeatedly call InternetReadFile to read data into a buffer (I use a 128k buffer), writing the data to a file and updating the progress bar as you go.
Declarations to get you started:
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function HttpQueryInfo Lib "wininet.dll" Alias "HttpQueryInfoA" (ByVal hHttpRequest As Long, ByVal lInfoLevel As Long, ByRef sBuffer As Any, ByRef lBufferLength As Long, ByRef lIndex As Long) As Long
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, ByRef Buffer As Any, ByVal lNumberOfBytesToRead As Long, lNumberOfBytesRead As Long) As Integer
Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" (ByVal hInternet As Long, ByVal lpszUrl As String, ByVal lpszHeaders As String, ByVal dwHeadersLength As Long, ByVal dwFlags As Long, ByVal dwContext As Long) As Long
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_KEEP_CONNECTION = &H400000 ' use keep-alive semantics - required for NTLM proxy authentication
Private Const HTTP_QUERY_CONTENT_LENGTH = 5
Private Const HTTP_QUERY_FLAG_NUMBER = &H20000000
If you need any clarification, post a comment.
You want a progress bar in VBA, wouldn't one of these approaches work?
Progress bar in VBA Excel
Seems a lot simpler than doing it as you describe, or am I not understanding?
OK, try this. Get the headers from the URL and parse them for Content-Length. Then you can set your progress bar accordingly.
Function GetFileSize(URL As String) As Long
Dim xml As Object ' MSXML2.XMLHTTP60
Dim result As String
Set xml = CreateObject("MSXML2.XMLHTTP.6.0")
With xml
' get headers only
.Open "HEAD", URL, False
.send
End With
result = xml.getResponseHeader("Content-Length")
GetFileSize = CLng(result)
End Function
Now just call the function with the URL of the file you want to download. It should give you the number of bytes of the file.
I am using CreateFile, WriteFile and ReadFile API calls to write some data to a USB device. The code I have works perfectly on 32 bit systems. CreateFile gets a handle to the device, pass that handle and some data to WriteFile and read from that handle with ReadFile.
My problem is, the same code does not work on a 64 bit system. The error returned from WriteFile is 6, The handle is invalid. I've checked the handle for validity on the CreateFile call and it is a valid handle. A call to GetLastError() returns 0 after CreateFile. The "file" is being opened for overlapped communication and the overlapped init calls are also returning their proper values.
My question: is there some sort of different consideration I need to make because it's a 64 bit system? A different flag? A different call altogether?
Just to note, I did a little bit of a hack on the code to make it synchronous (took out the OVERLAPPED) and it worked, so I'm assuming the problem is in my OVERLAPPED structure or the way I'm initializing the calls.
Any help is greatly appreciated.
Edit:
Below are my API signatures and the code I am using for my OVERLAPPED implementation
Private Declare Auto Function CreateFile Lib "kernel32.dll" _
(ByVal lpFileName As String, _
ByVal dwDesiredAccess As Integer, _
ByVal dwShareMode As Integer, _
ByVal lpSecurityAttributes As IntPtr, _
ByVal dwCreationDisposition As Integer, _
ByVal dwFlagsAndAttributes As Integer, _
ByVal hTemplateFile As IntPtr) As IntPtr
Private Declare Auto Function WriteFile Lib "kernel32.dll" _
(ByVal hFile As IntPtr, ByVal Buffer As Byte(), _
ByVal nNumberOfBytesToWrite As Integer, _
ByRef lpNumberOfBytesWritten As Integer, _
ByRef lpOverlapped As OVERLAPPED) As Boolean
Private Declare Auto Function ReadFile Lib "kernel32.dll" _
(ByVal hFile As IntPtr, _
ByVal Buffer As Byte(), _
ByVal nNumberOfBytesToRead As Integer, _
ByRef lpNumberOfBytesRead As Integer, _
ByRef lpOverlapped As OVERLAPPED) As Boolean
Private Declare Auto Function CloseHandle Lib "kernel32.dll" (ByVal hFile As IntPtr) As Boolean
Private Declare Auto Function CancelIo Lib "kernel32.dll" (ByVal hObject As IntPtr) As Boolean
Private Declare Auto Function GetOverlappedResult Lib "kernel32.dll" ( _
ByVal hFile As IntPtr, ByRef lpOverlapped As OVERLAPPED, _
ByRef lpNumberOfBytesTransferred As Integer, _
ByVal bWait As Boolean) As Boolean
Private Declare Auto Function CreateEvent Lib "kernel32.dll" ( _
ByVal lpEventAttributes As Integer, ByVal bManualReset As Boolean, _
ByVal bInitialState As Boolean, _
<MarshalAs(UnmanagedType.LPStr)> ByVal lpName As String) As IntPtr
Private Declare Auto Function WaitForSingleObject Lib "kernel32.dll" ( _
ByVal hHandle As IntPtr, ByVal dwMilliseconds As Integer) As Integer
The following is the code for the write, where the issue occurs. It should be noted that in the read, the OVERLAPPED structure's hEvent parameter is initialized in the same fashion
Try
With IOStructure
.overlap.hEvent = CreateEvent(Nothing, True, False, Nothing)
If .overlap.hEvent = 0 Then
writeSuccess = False
Else
writeSuccess = WriteFile(.hdevice, .writeBuf, .writeBuf.Length, .bytesWritten, .overlap)
'If the write didn't succeed, check to see if it's pending
If Not writeSuccess Then
If Err.LastDllError <> ERROR_IO_PENDING Then 'The write failed
writeSuccess = False
Else ' Write is pending
Select Case WaitForSingleObject(.overlap.hEvent, .timeout * 0.1) 'Wait for the write to complete
Case 0 'The write completed, check the overlapped structure for the signalled event.
writeSuccess = GetOverlappedResult(.hdevice, .overlap, .bytesWritten, 0)
Case Else
writeSuccess = False
End Select
End If
End If
End If
CloseHandle(.overlap.hEvent)
End With
' Thread.Sleep(IOStructure.timeout * 0.3)
' End While
Catch
writeSuccess = False
End Try
I had the same problem... I found that the invalid handle error disappeared when I explicitly zeroed the overlapped structure:
Dim ovl As OVERLAPPED
static ovlRead As IntPtr = Nothing
' Marshal (allocate unmanaged) structure only once
If IsNothing(ovlRead) then
ovlRead = Marshal.AllocHGlobal(Marshal.SizeOf(ovl))
Marshal.WriteInt32(ovlRead, 0, 0)
Marshal.WriteInt32(ovlRead, 4, 0)
Marshal.WriteInt32(ovlRead, 8, 0)
Marshal.WriteInt32(ovlRead, 12, 0)
Marshal.WriteInt32(ovlRead, 16, 0)
End If
Good luck.
I had the exact same problem. Same symptoms. I fixed it by
At program start-up when I first open the port I purge the I/O buffers
I then write a 0x00 (null) character to the port itself using WriteFile to initialize it.
And BINGO it works. Haven't had problems since.
Why don't you just use NativeOverlapped? It's specifically designed for this task.