I am trying to use the function URLDownloadToFile in Access 2010 VBA code. When i run the code it tells me that URLDownloadToFile is not defined.
I have read that this function is in the urlmon.dll which i DO have on my computer. I tried to click the references button in the code editor and load it but it would not let me do so.
How can I fix this so I can use the function? Or is there another function that will allow me to download a url to to a file?
You'll need to declare this WinAPI function in order to call it from procedures in your code.
From HERE
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(URL As String, LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then
If Dir(LocalFileName) <> vbNullString Then
DownloadFile = True
End If
End If
End Function
Private Sub Form_Load()
If Not DownloadFile("http://www.ex-designz.net", "c:\\photogallery.asp") Then
MsgBox "Unable to download the file, or the source URL doesn't exist."
End If
End Sub
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
We have a user table in a SQL Server 2014 that I link to in an Access database front end and the password is in binary 64 so that the password cannot be seen if someone were to open the table somehow in SSMS.
But Access knows all this and completely converts it to the actual password. How do I get around this yet still use it to validate data entered into a login form?
You hash the password. Storing passwords as plaintext without hashing is a major bad practice.
Read more about hashing on Wikipedia. The short version it's a one-way operation: if you have the password, you can create the hash, but if you have the hash, there's no way to get the password except trying to hash random passwords and see if they're the same.
However, hashing in VBA is rather complicated. There are more simple answers that use .Net hashing objects, but I use the CNG API, which has numerous advantages such as hardware crypto support, zero dependencies and flexibility in the choice of algorithm:
Public Declare PtrSafe Function BCryptOpenAlgorithmProvider Lib "BCrypt.dll" (ByRef phAlgorithm As LongPtr, ByVal pszAlgId As LongPtr, ByVal pszImplementation As LongPtr, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptCloseAlgorithmProvider Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptCreateHash Lib "BCrypt.dll" (ByVal hAlgorithm As LongPtr, ByRef phHash As LongPtr, pbHashObject As Any, ByVal cbHashObject As Long, ByVal pbSecret As LongPtr, ByVal cbSecret As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptHashData Lib "BCrypt.dll" (ByVal hHash As LongPtr, pbInput As Any, ByVal cbInput As Long, Optional ByVal dwFlags As Long = 0) As Long
Public Declare PtrSafe Function BCryptFinishHash Lib "BCrypt.dll" (ByVal hHash As LongPtr, pbOutput As Any, ByVal cbOutput As Long, ByVal dwFlags As Long) As Long
Public Declare PtrSafe Function BCryptDestroyHash Lib "BCrypt.dll" (ByVal hHash As LongPtr) As Long
Public Declare PtrSafe Function BCryptGetProperty Lib "BCrypt.dll" (ByVal hObject As LongPtr, ByVal pszProperty As LongPtr, ByRef pbOutput As Any, ByVal cbOutput As Long, ByRef pcbResult As Long, ByVal dfFlags As Long) As Long
Public Function NGHash(pData As LongPtr, lenData As Long, Optional HashingAlgorithm As String = "SHA1") As Byte()
'Erik A, 2019
'Hash data by using the Next Generation Cryptography API
'Loosely based on https://learn.microsoft.com/en-us/windows/desktop/SecCNG/creating-a-hash-with-cng
'Allowed algorithms: https://learn.microsoft.com/en-us/windows/desktop/SecCNG/cng-algorithm-identifiers. Note: only hash algorithms, check OS support
'Error messages not implemented
On Error GoTo VBErrHandler
Dim errorMessage As String
Dim hAlg As LongPtr
Dim algId As String
'Open crypto provider
algId = HashingAlgorithm & vbNullChar
If BCryptOpenAlgorithmProvider(hAlg, StrPtr(algId), 0, 0) Then GoTo ErrHandler
'Determine hash object size, allocate memory
Dim bHashObject() As Byte
Dim cmd As String
cmd = "ObjectLength" & vbNullString
Dim Length As Long
If BCryptGetProperty(hAlg, StrPtr(cmd), Length, LenB(Length), 0, 0) <> 0 Then GoTo ErrHandler
ReDim bHashObject(0 To Length - 1)
'Determine digest size, allocate memory
Dim hashLength As Long
cmd = "HashDigestLength" & vbNullChar
If BCryptGetProperty(hAlg, StrPtr(cmd), hashLength, LenB(hashLength), 0, 0) <> 0 Then GoTo ErrHandler
Dim bHash() As Byte
ReDim bHash(0 To hashLength - 1)
'Create hash object
Dim hHash As LongPtr
If BCryptCreateHash(hAlg, hHash, bHashObject(0), Length, 0, 0, 0) <> 0 Then GoTo ErrHandler
'Hash data
If BCryptHashData(hHash, ByVal pData, lenData) <> 0 Then GoTo ErrHandler
If BCryptFinishHash(hHash, bHash(0), hashLength, 0) <> 0 Then GoTo ErrHandler
'Return result
NGHash = bHash
ExitHandler:
'Cleanup
If hAlg <> 0 Then BCryptCloseAlgorithmProvider hAlg, 0
If hHash <> 0 Then BCryptDestroyHash hHash
Exit Function
VBErrHandler:
errorMessage = "VB Error " & Err.Number & ": " & Err.Description
ErrHandler:
If errorMessage <> "" Then MsgBox errorMessage
Resume ExitHandler
End Function
Public Function HashBytes(Data() As Byte, Optional HashingAlgorithm As String = "SHA512") As Byte()
HashBytes = NGHash(VarPtr(Data(LBound(Data))), UBound(Data) - LBound(Data) + 1, HashingAlgorithm)
End Function
Public Function HashString(str As String, Optional HashingAlgorithm As String = "SHA512") As Byte()
HashString = NGHash(StrPtr(str), Len(str) * 2, HashingAlgorithm)
End Function
You can now use the HashString function to hash passwords. When someone enters a password, always use HashString(password) to look up the password or store a hashed password. You never store an actual unhashed password.
Of course, this also means that even you can not view passwords of users, only their hashes.
If you want to improve this further, you can use a salt to avoid rainbow table attacks. But only adding a hash will already substantially improve security.
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 have some controls in MS Access form that change the system language to Turkish, Arabic and English and I want to change the system language to English when I go to VBA to write some code.
I have a code that change system language and want to know
How to run this code automatically when I activate VBA editor?
If you put the following code on start of your application, it would run automatically Test2, whenever you press Alt+F11.
Private Sub Workbook_Open()
Application.OnKey "%{F11}", "Test2"
End Sub
Public Sub Test2()
Debug.Print "tested"
End Sub
I am not sure whether this is exactly what you want, but it is a work around to achieve it.
Edit:
Actually, here you may find plenty of useful stuff:
http://www.mrexcel.com/forum/excel-questions/468063-determine-language-user.html
E.g. With the Sub ShowLanguages you may built a function telling you which language are you using and if it is not English, you may switch to it, the way you do it in your answer. I would probably built something similar later.
Private Const LOCALE_ILANGUAGE As Long = &H1
Private Const LOCALE_SCOUNTRY As Long = &H6
Private Declare Function GetKeyboardLayout Lib "user32" _
(ByVal dwLayout As Long) As Long
Private Declare Function GetLocaleInfo Lib "kernel32" _
Alias "GetLocaleInfoA" _
(ByVal Locale As Long, _
ByVal LCType As Long, _
ByVal lpLCData As String, _
ByVal cchData As Long) As Long
Public Sub ShowLangauges()
Dim hKeyboardID As Long
Dim LCID As Long
hKeyboardID = GetKeyboardLayout(0&)
If hKeyboardID > 0 Then
LCID = LoWord(hKeyboardID)
Debug.Print GetUserLocaleInfo(LCID, LOCALE_ILANGUAGE)
Debug.Print GetUserLocaleInfo(LCID, LOCALE_SCOUNTRY)
End If
End Sub
Private Function LoWord(wParam As Long) As Integer
If wParam And &H8000& Then
LoWord = &H8000& Or (wParam And &H7FFF&)
Else
LoWord = wParam And &HFFFF&
End If
End Function
Public Function GetUserLocaleInfo(ByVal dwLocaleID As Long, _
ByVal dwLCType As Long) As String
Dim sReturn As String
Dim nSize As Long
nSize = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn))
If nSize > 0 Then
sReturn = Space$(nSize)
nSize = GetLocaleInfo(dwLocaleID, dwLCType, sReturn, Len(sReturn))
If nSize > 0 Then
GetUserLocaleInfo = Left$(sReturn, nSize - 1)
End If
End If
End Function
I use Timer to check if VBA editor window is the active window every 0.5 Sec and if true I run my function that change the language to English and stop Timer:
Private Sub Form_Timer()
Dim st As String
On Error Resume Next
st = VBE.ActiveWindow.Caption
If Err = 0 Then
ChLng 1033
Me.TimerInterval = 0
End If
On Error GoTo 0
End Sub
And I run Timer again when any control on my form change the language to non English language:
Private Sub cmbAR_GotFocus()
ChLng 1025
Me.TimerInterval = 500
End Sub
Private Sub cmbTR_GotFocus()
ChLng 1055
Me.TimerInterval = 500
End Sub
In Form design I manually add all needed events including Form Load event that run the Timer:
Private Sub Form_Load()
Me.TimerInterval = 500
End Sub
NOTE: ChLng xxxx is the function that change the language:
(Find your desired language at BCP 47 Code)
Private Declare Function ActivateKeyboardLayout Lib _
"user32.dll" (ByVal myLanguage As Long, Flag As Boolean) As Long
'define your desired keyboardlanguage
Sub ChLng(lng As Long)
ActivateKeyboardLayout lng, 0
End Sub
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.