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.
Related
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've successfully removed the ribbon on startup by using this line of code:
DoCmd.ShowToolbar "Ribbon", acToolbarNo
But this also removes the Quick Access Toolbar. I want this to stay so that the user can only see the icons I've selected to be shown (Copy, Paste, Export to Excel, etc,.)
My ultimate goal is to have only these icons appear, and the header to be otherwise empty, thin and out of the way. I'm trying to save as much screen space as possible, and I do not want the user to have to ability to expand the ribobn.
Is there a similar line of code that will force the QAT to be shown. Furthermore, is there a way to select which shortcuts will appear in the QAT with VBA. I know this can be done manually, but I'm trying to automate it.
Looks like it's possible using custom Access XML
Start by going and reading through this
https://support.office.com/en-us/article/Customize-the-Ribbon-45e110b9-531c-46ed-ab3a-4e25bc9413de
and then you'll need to create your own bit of XML code to control everything
here a list of the control idMso to use http://www.ribboncreator2010.de/Onlinehelp/EN/_2el0osmon.htm
the following is a something i whipped together as a proof of concept
<?xml version="1.0" encoding="UTF-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui">
<ribbon startFromScratch="true">
<tabs>
<tab idMso="TabAddIns">
</tab>
</tabs>
<qat>
<documentControls>
<control idMso="SaveObjectAs" />
</documentControls>
</qat>
</ribbon>
</customUI>
this is what is looks like
Not sure how helpful is replying to 5 years old thread, but who knows...
Few days ago I had to (finally) move from Access 2010 to 2021 and was stunned with new UI in general, but mostly with how much space is wasted at the top, especially for my usual scenario for distributed apps - QAT without ribbons and everything else on the right mouse. I didn't take it very seriously at first, believing I'm not the only one with such layout and ready-made solution(s) would be there, in numbers. That was a second surprise, because there are none. "Blank" ribbon is still wasting 40-50px of space with File ribbon not removable. Aside from ruining the concept, everybody will ask "Why is this blank File menu there doing nothing...??"
This is not very difficult to solve, but (like everybody else) I prefer copy/paste to writing own solution from scratch, sadly it was not there to grab :) So here's simple solution for those who want their ~40px back :)
It is assumed you handle all the usual stuff like hiding navigation bar, prevent F11, opening with Shift, hiding Taskbar etc. Or not. It will work even in "design" mode scenarios, but it's not meant for that. For now I simply hardcoded 45px for Window bar/QAT height, can be modified, calculated, but can't be bothered at the moment. Also, this will not work with Access 2010 and earlier, can be made to work if somebody wants to play with it, I'll not
Here's code
Somewhere in your start up routine add these 2 lines of code
moveMDIUp
SubClass_On Access.hWndAccessApp
Create new Code module and insert this code:
'######################################################################
'Module to show only QAT and hide the ribbon
'Miroslav, June 2022
'######################################################################
Option Compare Database
Option Explicit
'Set height of window/QAT bar you wish to keep/see
Private Const QAT_Height = 45
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As LongPtr, ByVal hWndChildAfter As LongPtr, ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As LongPtr
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As LongPtr
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As LongPtr
Private Declare PtrSafe Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hwnd As LongPtr, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal wNewWord As LongPtr) As LongPtr
Private Const GWL_WNDPROC = (-4)
Private Const WM_WINDOWPOSCHANGED = &H47
Private Const WM_SYSCOMMAND = &H112
Private m_PrevProc As LongPtr
Private m_PrevProcSH As LongPtr
Private SHDhwnd As LongPtr
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Sub moveMDIUp()
Dim MDIhwnd, ACChwnd, TASKhwnd, NAVhwnd, RIBhwnd, s
Dim navWidth As Long: Dim taskHeight As Long: Dim ribHeight As Long: Dim accWidth As Long: Dim accHeight As Long: Dim mRECT As RECT
ACChwnd = Application.hWndAccessApp
MDIhwnd = FindWindowEx(ACChwnd, 0, "MDIClient", vbNullString)
SHDhwnd = FindWindowEx(ACChwnd, 0, "DropShadow", vbNullString)
'Hide shadow below the ribbon
ShowWindow SHDhwnd, 0
'Get Access width and height
GetWindowRect ACChwnd, mRECT
accHeight = mRECT.Bottom - mRECT.Top
accWidth = mRECT.Right - mRECT.Left
'Find height of taskbar, if not shown it's 0 height
TASKhwnd = FindWindowEx(ACChwnd, 0, "MsoCommandBarDock", "MsoDockBottom")
TASKhwnd = FindWindowEx(TASKhwnd, 0, "MsoCommandBar", "Status Bar")
GetWindowRect TASKhwnd, mRECT
taskHeight = mRECT.Bottom - mRECT.Top
s = SetWindowPos(MDIhwnd, 0, 0, QAT_Height, accWidth - 2, accHeight - QAT_Height - taskHeight - 1, 0)
End Sub
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
WindowProc = CallWindowProc(m_PrevProc, hwnd, uMsg, wParam, lParam)
If (uMsg = WM_SYSCOMMAND) And (wParam = 61536) Then
'unhook here...
Call SubClass_Off(Application.hWndAccessApp)
Call SubClassSH_Off(SHDhwnd)
Exit Function
End If
End Function
Public Function SubClass_On(ByVal hwnd As Long)
m_PrevProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)
Call SubClassSH_On(SHDhwnd)
End Function
Public Function SubClass_Off(ByVal hwnd As Long)
SetWindowLong hwnd, GWL_WNDPROC, m_PrevProc
End Function
Public Function WindowProcSH(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
WindowProcSH = CallWindowProc(m_PrevProcSH, hwnd, uMsg, wParam, lParam)
If uMsg = WM_WINDOWPOSCHANGED Then
moveMDIUp
End If
End Function
Public Function SubClassSH_On(ByVal hwnd As Long)
m_PrevProcSH = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProcSH)
End Function
Public Function SubClassSH_Off(ByVal hwnd As Long)
SetWindowLong hwnd, GWL_WNDPROC, m_PrevProcSH
End Function
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.
I'd like to use a .png as a custom icon in the Access 2007 ribbon.
Here's what I've tried so far:
I am able to load .bmp's and .jpg's as custom images without any problem. I can load .gif's, but it doesn't seem to preserve the transparency. I can't load .png's at all. I'd really like to use .png's to take advantage of the alpha-blending that is not available in the other formats.
I found a similar question on SO, but that just deals with loading custom icons of any kind. I am specifically interested in .png's. There is an answer from Albert Kallal to that question that links to a class module he had written that appears to do exactly what I want:
meRib("Button1").Picture = "HappyFace.png"
Unfortunately, the link in that answer is dead.
I also found this site which offers a download of a 460 line module full of dozens of API calls to get support for transparent icons. Before I go that route I wanted to ask the experts here if they know of a better way.
I know .png is pretty new-fangled and all, but I'm hoping the Office development folks slipped in some native support for the format.
Here is what I am currently using. Albert Kallal has a more full-fledged solution for Access 2007 ribbon programming that does a lot more than just load .png's. I am not using it yet, but it's worth checking out.
For those who are interested, here is the code that I am using. I believe this is pretty close to the minimum required for .png support. If there's anything extraneous here, let me know and I'll update my answer.
Add the following to a standard code module:
Option Compare Database
Option Explicit
'================================================================================
' Declarations required to load .png's in Ribbon
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PICTDESC
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, _
inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, bitmap As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As Long, _
hbmReturn As Long, ByVal background As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal image As Long) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, _
RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'================================================================================
Public Sub GetRibbonImage(ctl As IRibbonControl, ByRef image)
Dim Path As String
Path = Application.CurrentProject.Path & "\Icons\" & ctl.Tag
Set image = LoadImage(Path)
End Sub
Private Function LoadImage(ByVal strFName As String) As IPicture
Dim uGdiInput As GdiplusStartupInput
Dim hGdiPlus As Long
Dim hGdiImage As Long
Dim hBitmap As Long
uGdiInput.GdiplusVersion = 1
If GdiplusStartup(hGdiPlus, uGdiInput) = 0 Then
If GdipCreateBitmapFromFile(StrPtr(strFName), hGdiImage) = 0 Then
GdipCreateHBITMAPFromBitmap hGdiImage, hBitmap, 0
Set LoadImage = ConvertToIPicture(hBitmap)
GdipDisposeImage hGdiImage
End If
GdiplusShutdown hGdiPlus
End If
End Function
Private Function ConvertToIPicture(ByVal hPic As Long) As IPicture
Dim uPicInfo As PICTDESC
Dim IID_IDispatch As GUID
Dim IPic As IPicture
Const PICTYPE_BITMAP = 1
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With uPicInfo
.Size = Len(uPicInfo)
.Type = PICTYPE_BITMAP
.hPic = hPic
.hPal = 0
End With
OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
Set ConvertToIPicture = IPic
End Function
Then, if you don't already have one, add a table named USysRibbons. (NOTE: Access treats this table as a system table, so you'll have to show those in your nav pane by going to Access Options --> Current Database --> Navigation Options and make sure 'Show System Objects' is checked.) Then add these attributes to your control tag:
getImage="GetRibbonImage" tag="Acq.png"
For example:
<button id="MyButtonID" label="Do Something" enabled="true" size="large"
getImage="GetRibbonImage" tag="MyIcon.png" onAction="MyPublicSub"/>
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.