I've hit a brick wall trying to get FTP working in Excel VBA (64-bit Office on 64-bit Windows 10). As an early proof of concept, I'm just trying to list the name of the single text file that I've uploaded to the FTP server.
The sub I'm running is ListFilesOnFTP. hOpen and hConnection both get set to handle values successfully by InternetOpen and InternetConnect respecitvely.
blReturn is set to True by FtpSetCurrentDirectory, indicating that this is not failing.
The problem I have is in EnumFiles - no matter what combination of wildcards I use for lpszSearchfile, FtpFindFirstFile always returns zero, and therefore EnumFiles exits immediately.
Obviously I have provided placeholder values below for strFTPServerIP, strUsername, strPassword and strRemoteDirectory, but I am 100% certain that the IP address and credentials are correct, and that the directory with the provided name does exist under the root of the FTP server.
Any ideas where I'm going wrong here?
Relevant constant and type declarations:
Private Const MAX_PATH As Integer = 260
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Private Const INTERNET_DEFAULT_FTP_PORT = 21
Private Const INTERNET_SERVICE_FTP = 1
Private Const INTERNET_FLAG_PASSIVE = &H8000000
Private Const INTERNET_NO_CALLBACK = 0
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Relevant wininet.dll function declarations (please note - I do have these wrapped in the usual #If VBA7 Then... #Else... #End If conditional compilation structures, with 32-bit compatible declarations in the else clause, but for brevity I have only provided the PtrSafe functions here):
Private Declare PtrSafe Function InternetCloseHandle Lib "wininet.dll" ( _
ByVal hInet As LongPtr) As LongPtr
Private Declare PtrSafe Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
ByVal sAgent As String, _
ByVal lAccessType As LongPtr, _
ByVal sProxyName As String, _
ByVal sProxyBypass As String, _
ByVal lFlags As LongPtr) As LongPtr
Private Declare PtrSafe Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
ByVal hInternetSession As LongPtr, _
ByVal sServerName As String, _
ByVal nServerPort As LongPtr, _
ByVal sUsername As String, _
ByVal sPassword As String, _
ByVal lService As LongPtr, _
ByVal lFlags As LongPtr, _
ByVal lContext As LongPtr) As LongPtr
Private Declare PtrSafe Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" ( _
ByVal hFtpSession As LongPtr, _
ByVal lpszDirectory As String) As Boolean
Private Declare PtrSafe Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" ( _
ByVal hFtpSession As LongPtr, _
ByVal lpszCurrentDirectory As String, _
ByVal lpdwCurrentDirectory As LongPtr) As LongPtr
Private Declare PtrSafe Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" ( _
ByVal hFtpSession As LongPtr, _
ByVal lpszSearchFile As String, _
ByRef lpFindFileData As WIN32_FIND_DATA, _
ByVal dwFlags As LongPtr, _
ByVal dwContent As LongPtr) As LongPtr
Procedures using the above:
Public Sub EnumFiles(ByVal hConnection As LongPtr)
Dim pData As WIN32_FIND_DATA
#If VBA7 Then
Dim hFind As LongPtr, lRet As LongPtr
#Else
Dim hFind As Long, lRet As Long
#End If
' Create a buffer
pData.cFileName = String(MAX_PATH, vbNullChar)
' Find the first file
hFind = FtpFindFirstFile(hConnection, "*.*", pData, INTERNET_FLAG_RELOAD Or INTERNET_FLAG_NO_CACHE_WRITE, 0)
' If there's no file, then exit sub
If hFind = 0 Then Exit Sub
' Show the filename
MsgBox Left$(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
Do
' Create a buffer
pData.cFileName = String(MAX_PATH, vbNullChar)
' Find the next file
lRet = InternetFindNextFile(hFind, pData)
' If there's no next file, exit loop
If lRet = 0 Then Exit Do
' Show the filename
MsgBox Left$(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
Loop
' Close the search handle
InternetCloseHandle hFind
End Sub
Public Sub ListFilesOnFTP()
#If VBA7 Then
Dim hOpen As LongPtr, hConnection As LongPtr
#Else
Dim hOpen As Long, hConnection As Long
#End If
Dim blReturn As Boolean
Dim strFTPServerIP As String, strUsername As String, strPassword As String, _
strRemoteDirectory As String
strFTPServerIP = "12.345.678.901"
strUsername = "username"
strPassword = "password"
strRemoteDirectory = "directory_name/"
' Open an internet connection
hOpen = InternetOpen("FTP", _
INTERNET_OPEN_TYPE_PRECONFIG, _
vbNullString, _
vbNullString, _
0)
hConnection = InternetConnect( _
hOpen, _
strFTPServerIP, _
INTERNET_DEFAULT_FTP_PORT, _
strUsername, _
strPassword, _
INTERNET_SERVICE_FTP, _
INTERNET_FLAG_PASSIVE, _
INTERNET_NO_CALLBACK)
blReturn = FtpSetCurrentDirectory(hConnection, strRemoteDirectory)
Call EnumFiles(hConnection)
InternetCloseHandle hConnection
InternetCloseHandle hOpen
End Sub
Cross-posted here: excelforum.com
And here: mrexcel.com
So I gave up on this idea a couple of weeks ago, got rid of the FTP server I'd created, and had resolved to rethinking my approach to the problem I was trying to solve with FTP.
But... although my original FTP server is now long gone, I just made some changes to the API declarations after some advice from elsewhere about the datatypes of arguments to API calls not necessarily having to be LongPtrs (depends if the API function expects a Long), and then went looking for a test FTP server - found one here: https://dlptest.com/ftp-test/
Connected to it in File Explorer, used netstat -abno in command prompt to find the 'foreign address' with port 21 at the end of it, and used that IP in my code, along with the credentials listed on the webpage above.
And then boom...
immediate window output
actual directory content
As you can see, FtpGetCurrentDirectory doesn't like one of the parameters I'm passing it (a quick Google suggests that's what LastDllError code 87 means), but FtpSetCurrentDirectory obviously did run OK (the directory was set successfully)... so the hFtpSession argument being a LongPtr can't be a huge problem (or it is a problem for FtpGetCurrentDirectory, but weirdly not for FtpSetCurrentDirectory).
I tried changing all the parameters in the PtrSafe declarations to Longs, but because some of them are LongPtrs returned by other API calls, to get the code to compile I had to relent and put some parameters back to being LongPtrs.
So either the changes to the API declarations worked, or there was a problem with the previous FTP server that I got rid of which caused FtpFindFirstFile to fail.
Anyway... my working code in full (bear in mind that because this is an open test FTP server, the directories which exist on there are changing all the time... the one in my code below and in the screenshots above is now no longer there!! Just connect to it via File Explorer or FileZilla first to get the name of a directory which currently exists, and set strRemoteDirectory in ListFilesOnFTP to that):
Option Explicit
Private Const FTP_TRANSFER_TYPE_UNKNOWN = &H0
Private Const FTP_TRANSFER_TYPE_ASCII = &H1
Private Const FTP_TRANSFER_TYPE_BINARY = &H2
Private Const INTERNET_SERVICE_FTP = 1
Private Const INTERNET_SERVICE_HTTP = 3
Private Const INTERNET_OPEN_TYPE_PRECONFIG = 0 ' use registry configuration
Private Const INTERNET_OPEN_TYPE_DIRECT = 1 ' direct to net
Private Const INTERNET_OPEN_TYPE_PROXY = 3 ' via named proxy
Private Const INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4 ' prevent using java/script/INS
Private Const INTERNET_CONNECTION_CONFIGURED = &H40
Private Const INTERNET_CONNECTION_LAN = &H2
Private Const INTERNET_CONNECTION_MODEM = &H1
Private Const INTERNET_CONNECTION_OFFLINE = &H20
Private Const INTERNET_CONNECTION_PROXY = &H4
Private Const INTERNET_RAS_INSTALLED = &H10
Private Const INTERNET_INVALID_PORT_NUMBER = 0
Private Const INTERNET_DEFAULT_FTP_PORT = 21
Private Const INTERNET_DEFAULT_GOPHER_PORT = 70
Private Const INTERNET_DEFAULT_HTTP_PORT = 80
Private Const INTERNET_DEFAULT_HTTPS_PORT = 443
Private Const INTERNET_DEFAULT_SOCKS_PORT = 1080
Private Const INTERNET_NO_CALLBACK = 0
Private Const INTERNET_FLAG_PASSIVE = &H8000000 ' used for FTP connections
Private Const INTERNET_FLAG_RELOAD = &H80000000
Private Const INTERNET_FLAG_NO_CACHE_WRITE = &H4000000
Private Const MAX_PATH As Integer = 260
Private Const GENERIC_READ = &H80000000
Private Const MAXDWORD As Double = (2 ^ 32) - 1
Private Const ERROR_NO_MORE_FILES = 18&
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
#If Win64 Then
Private Declare PtrSafe Function InternetGetConnectedState Lib "wininet.dll" ( _
ByRef dwFlags As Long, ByVal dwReserved As Long) As LongPtr
Private Declare PtrSafe Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" ( _
ByVal lpszUrl As String, _
ByVal dwFlags As Long, _
ByVal dwReserved As Long) As Boolean
Private Declare PtrSafe Function InternetCloseHandle Lib "wininet.dll" ( _
ByVal hInet As LongPtr) As LongPtr
Private Declare PtrSafe 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 LongPtr
Private Declare PtrSafe Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
ByVal hInternetSession As LongPtr, _
ByVal sServerName As String, _
ByVal nServerPort As Long, _
ByVal sUsername As String, _
ByVal sPassword As String, _
ByVal lService As Long, _
ByVal lFlags As Long, _
ByVal lContext As Long) As LongPtr
Private Declare PtrSafe Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" ( _
ByVal hFtpSession As LongPtr, _
ByVal lpszDirectory As String) As Boolean
Private Declare PtrSafe Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" ( _
ByVal hFtpSession As LongPtr, _
ByVal lpszCurrentDirectory As String, _
ByVal lpdwCurrentDirectory As LongPtr) As Boolean
Private Declare PtrSafe Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" ( _
ByVal lpdwError As Long, _
ByVal lpszBuffer As String, _
ByVal lpdwBufferLength As Long) As Boolean
Private Declare PtrSafe Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" ( _
ByVal hFtpSession As LongPtr, _
ByVal lpszSearchFile As String, _
ByRef lpFindFileData As WIN32_FIND_DATA, _
ByVal dwFlags As Long, _
ByVal dwContent As Long) As LongPtr
Private Declare PtrSafe Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" ( _
ByVal hFind As LongPtr, _
ByRef lpFindData As WIN32_FIND_DATA) As LongPtr
#Else
Private Declare Function InternetGetConnectedState Lib "wininet.dll" ( _
ByRef dwflags As Long, ByVal dwReserved As Long) As Long
Private Declare Function InternetCheckConnection Lib "wininet.dll" Alias "InternetCheckConnectionA" ( _
ByVal lpszUrl As String, _
ByVal dwFlags As Long, _
ByVal dwReserved As Long) As Boolean
Private Declare Function InternetCloseHandle Lib "wininet.dll" ( _
ByVal hInet As Long) As Long
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 InternetConnect Lib "wininet.dll" Alias "InternetConnectA" ( _
ByVal hInternetSession As Long, _
ByVal sServerName As String, _
ByVal nServerPort As Integer, _
ByVal sUserName As String, _
ByVal sPassword As String, _
ByVal lService As Long, _
ByVal lFlags As Long, _
ByVal lContext As Long) As Long
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" ( _
ByVal hFtpSession As Long, _
ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" ( _
ByVal hFtpSession As Long, _
ByVal lpszCurrentDirectory As String, _
lpdwCurrentDirectory As Long) As Boolean
Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" ( _
lpdwError As Long, _
ByVal lpszBuffer As String, _
lpdwBufferLength As Long) As Boolean
Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" ( _
ByVal hFtpSession As Long, _
ByVal lpszSearchFile As String, _
lpFindFileData As WIN32_FIND_DATA, _
ByVal dwFlags As Long, _
ByVal dwContent As Long) As Long
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" ( _
ByVal hFind As Long, _
lpFindData As WIN32_FIND_DATA) As Long
#End If
Public Sub EnumFiles(ByVal hConnection As LongPtr)
Dim pData As WIN32_FIND_DATA
#If Win64 Then
Dim hFind As LongPtr, lRet As LongPtr
#Else
Dim hFind As Long, lRet As Long
#End If
' Create a buffer
pData.cFileName = String(MAX_PATH, vbNullChar)
' Find the first file
hFind = FtpFindFirstFile(hConnection, "*.*", pData, INTERNET_FLAG_RELOAD Or INTERNET_FLAG_NO_CACHE_WRITE, 0)
' If there's no file, then exit sub
If hFind = 0 Then Exit Sub
' Show the filename
Debug.Print vbNewLine & "FILES FOUND:" & vbNewLine & Left$(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
Do
' Create a buffer
pData.cFileName = String(MAX_PATH, vbNullChar)
' Find the next file
lRet = InternetFindNextFile(hFind, pData)
' If there's no next file, exit loop
If lRet = 0 Then Exit Do
' Show the filename
Debug.Print Left$(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
Loop
' Close the search handle
InternetCloseHandle hFind
End Sub
Public Sub ListFilesOnFTP()
#If Win64 Then
Dim hOpen As LongPtr, hConnection As LongPtr, lngCurrentDirLength As LongPtr
#Else
Dim hOpen As Long, hConnection As Long, lngCurrentDirLength As Long
#End If
Dim fConnectionTestFlags As Long
Dim blCheckConnection As Boolean
Dim blCheckGetDirSuccess As Boolean, blCheckSetDirSuccess As Boolean
Dim strFTPServerIP As String, strUsername As String, strPassword As String
Dim strRemoteDirectory As String, strCurrentDirectory As String
strFTPServerIP = "35.163.228.146"
strUsername = "dlpuser"
strPassword = "rNrKYTX9g7z3RgJRmxWuGHbeu"
strRemoteDirectory = "File"
' Open an internet connection
hOpen = InternetOpen("FTP Client", _
INTERNET_OPEN_TYPE_DIRECT, _
vbNullString, _
vbNullString, _
0)
hConnection = InternetConnect( _
hOpen, _
strFTPServerIP, _
INTERNET_DEFAULT_FTP_PORT, _
strUsername, _
strPassword, _
INTERNET_SERVICE_FTP, _
INTERNET_FLAG_PASSIVE, _
INTERNET_NO_CALLBACK)
blCheckConnection = InternetCheckConnection(strFTPServerIP, 0, 0)
If blCheckConnection Then
InternetGetConnectedState fConnectionTestFlags, 0
' Debug.Print "INTERNET_CONNECTION_CONFIGURED = " & CBool((fConnectionTestFlags And INTERNET_CONNECTION_CONFIGURED) > 0)
' Debug.Print "INTERNET_CONNECTION_LAN = " & CBool((fConnectionTestFlags And INTERNET_CONNECTION_LAN) > 0)
' Debug.Print "INTERNET_CONNECTION_MODEM = " & CBool((fConnectionTestFlags And INTERNET_CONNECTION_MODEM) > 0)
' Debug.Print "INTERNET_CONNECTION_OFFLINE = " & CBool((fConnectionTestFlags And INTERNET_CONNECTION_OFFLINE) > 0)
' Debug.Print "INTERNET_CONNECTION_PROXY = " & CBool((fConnectionTestFlags And INTERNET_CONNECTION_PROXY) > 0)
' Debug.Print "INTERNET_RAS_INSTALLED = " & CBool((fConnectionTestFlags And INTERNET_RAS_INSTALLED) > 0)
blCheckSetDirSuccess = FtpSetCurrentDirectory(hConnection, strRemoteDirectory)
Debug.Print "Set current directory successful = " & blCheckSetDirSuccess
If blCheckSetDirSuccess Then
' Create buffer
strCurrentDirectory = String(MAX_PATH, vbNullChar)
blCheckGetDirSuccess = FtpGetCurrentDirectory(hConnection, strCurrentDirectory, lngCurrentDirLength)
If blCheckGetDirSuccess Then
Debug.Print "Current directory = " & strCurrentDirectory
Else
Debug.Print "Get current directory call failed - " & GetError
Debug.Print "LastDllError code = " & Err.LastDllError
End If
Call EnumFiles(hConnection)
End If
End If
InternetCloseHandle hConnection
InternetCloseHandle hOpen
End Sub
Private Function GetError() As String
Dim lngErrorCode As Long, strError As String, lngBufferLength As Long
Dim blGetInfoSuccess As Boolean
' Get the required buffer size
InternetGetLastResponseInfo lngErrorCode, strError, lngBufferLength
' Create a buffer
strError = String(lngBufferLength, 0)
' Retrieve the last response info
blGetInfoSuccess = InternetGetLastResponseInfo(lngErrorCode, strError, lngBufferLength)
If blGetInfoSuccess Then
GetError = "Error code " & CStr(lngErrorCode) & ": " & strError
Else
GetError = "error information could not be retrieved"
End If
End Function
Related
Dode below doesn't return an error, or "success" or "fail" but it also doesn't work - information in the sub TestUpload that is CAPITALIZED is the only info that i changed to make this post - everything else is legit - thanks in advance.
Option Compare Database
Private Const FTP_TRANSFER_TYPE_UNKNOWN As Long = 0
Private Const INTERNET_FLAG_RELOAD As Long = &H80000000
Private Declare Function InternetOpenA Lib "wininet.dll" ( _
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 InternetConnectA Lib "wininet.dll" ( _
ByVal hInternetSession As Long, _
ByVal sServerName As String, _
ByVal nServerPort As Long, _
ByVal sUsername As String, _
ByVal sPassword As String, _
ByVal lService As Long, _
ByVal lFlags As Long, _
ByVal lcontext As Long) As Long
Private Declare Function FtpPutFileA _
Lib "wininet.dll" _
_
(ByVal hFtpSession As Long, _
ByVal lpszLocalFile As String, _
ByVal lpszRemoteFile As String, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Boolean
Private Declare Function InternetCloseHandle Lib "wininet" ( _
ByVal hInet As Long) As Long
Sub FtpUpload(ByVal strLocalFile As String, ByVal strRemoteFile As String, ByVal strHost As String, ByVal lngPort As Long, ByVal strUser As String, ByVal strPass As String)
Dim hOpen As Long
Dim hConn As Long
hOpen = InternetOpenA("FTPGET", 1, vbNullString, vbNullString, 1)
hConn = InternetConnectA(hOpen, strHost, lngPort, strUser, strPass, 1, 0, 2)
If FtpPutFileA(hConn, strLocalFile, strRemoteFile, FTP_TRANSFER_TYPE_UNKNOWN Or INTERNET_FLAG_RELOAD, 0) Then
Debug.Print "Success"
Else
Debug.Print "Fail"
End If
'Close connections
InternetCloseHandle hConn
InternetCloseHandle hOpen
End Sub
Sub TestUpload()
FtpUpload "C:\Users\FOLDER\UPLOAD FILE.csv", "/<root>/SFTPSITE FOLDER NAME/admin", _
"IP.ADDRESS.OF.SFTPSITE", "22", "SIGNIN#sftp.DOMAIN.com", "PASSWORD"
End Sub
WinINet functions do not support SFTP protocol (FTP protocol is completely different).
There's no native support for SFTP in VBA nor in Windows API. You have to use a 3rd party library or software.
See these questions for some examples:
Using WinSCP scripting: Using VBA to run WinSCP script
Using WinSCP .NET assembly: Getting "user defined type not defined" when trying to use WinSCP .NET assembly in VBA to upload file to SFTP
(I'm the author of WinSCP)
I am trying to send WM_KEYDOWN and WM_KEYUP to notepad's edit control. The following example works, if I send a VK_F5: Notepad inserts the current date and time. However, If I try to send a simple h, notepad doesn't stop inserting one h after another so that I have to kill notepad with the task manager.
I don't understand why it works with one key and not with the other and I'd like to know what I have to change to send a simple letter.
option explicit
const WM_KEYDOWN = &h0100
const WM_KEYUP = &h0101
const VK_F5 = &h074
declare function FindWindow lib "user32" alias "FindWindowA" ( _
byVal lpClassName as string, _
byVal lpWindowName as string) as long
declare function FindWindowEx lib "user32" alias "FindWindowExA" ( _
byVal hWnd as long , _
byVal hWndChildAfter as long , _
byVal lpClassName as string, _
byVal lpWindowName as string) as long
declare function MapVirtualKey lib "user32" alias "MapVirtualKeyA" ( _
byVal wCode as long, _
byVal wMapType as long) as long
declare function PostMessage lib "user32" alias "PostMessageA" ( _
byVal hwnd as long, _
byVal wMsg as long, _
byVal wParam as long, _
lParam as any) as long
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 lpShowCmd as long) as long
declare sub Sleep lib "kernel32" (byVal dwMilliseconds as long )
sub main()
dim hWndNotepad as long
dim hWndNotepadEdit as long
'
' Start notepad
'
ShellExecute 0, "Open", "notepad.exe", "", "", 1
'
' Find the window handle for notepad
'
hWndNotepad = FindWindow("notepad", vbNullString)
while hWndNotepad = 0
'
' Wait a while if notepad window not yet initialized:
'
Sleep 100
hWndNotepad = FindWindow("notepad", vbNullString)
wend
'
' Find the window handle of the edit control
' in notepad:
'
hWndNotepadEdit = FindWindowEx(hWndNotepad, 0, "Edit", vbNullString)
dim vkCode as long
' This works:
' ----------
'
' vkCode = VK_F5
'
' This doesn't:
' ------------
vkCode = asc("H")
dim lParam as long
lParam = 1 + MapVirtualKey(vkCode, 0) * 2^16
PostMessage hWndNotepadEdit, WM_KEYDOWN, vkCode, lParam
Sleep 100
PostMessage hWndNotepadEdit, WM_KEYUP , vkCode, lParam or &hc0000000
end sub
You have a bug in declaration of PostMessage function (lParam as Any)
Correct is ByVal lParam as Long
Option Explicit
Const WM_KEYDOWN = &H100
Const WM_CHAR = &H102
Const WM_KEYUP = &H101
Const VK_F5 = &H74
Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
ByVal hwnd As Long, _
ByVal hWndChildAfter As Long, _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Declare Function MapVirtualKey Lib "user32" Alias "MapVirtualKeyA" ( _
ByVal wCode As Long, _
ByVal wMapType As Long) As Long
Declare Function PostMessage Lib "user32" Alias "PostMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
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 lpShowCmd As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub main()
Dim hWndNotepad As Long
Dim hWndNotepadEdit As Long
'
' Start notepad
'
ShellExecute 0, "Open", "notepad.exe", "", "", 1
'
' Find the window handle for notepad
'
hWndNotepad = FindWindow(vbNullString, "Bez názvu – Poznámkový blok")
While hWndNotepad = 0
'
' Wait a while if notepad window not yet initialized:
'
Sleep 100
hWndNotepad = FindWindow(vbNullString, "Bez názvu – Poznámkový blok")
Wend
'
' Find the window handle of the edit control
' in notepad:
'
hWndNotepadEdit = FindWindowEx(hWndNotepad, 0, "Edit", vbNullString)
Dim vkCode As Long
' This works:
' ----------
'
' vkCode = VK_F5
'
' This doesn't:
' ------------
vkCode = Asc("H")
Dim lParam As Long
lParam = 1 + MapVirtualKey(vkCode, 0) * (2 ^ 16)
Debug.Print Hex(vkCode), Hex(lParam)
PostMessage hWndNotepadEdit, WM_KEYDOWN, vkCode, lParam
' PostMessage hWndNotepadEdit, WM_KEYUP, vkCode, lParam Or &HC0000000
End Sub
You can send simple letters as well as other characters in hex format. For simple h it is Const VK_H = &H48. Some other examples:
Const VK_NUMPAD0 = &H60
Const VK_NUMPAD1 = &H61
Const VK_NUMPAD2 = &H62
VK_A thru VK_Z are the same as their ASCII equivalents: 'A' thru 'Z'
VK_0 thru VK_9 are the same as their ASCII equivalents: '0' thru '9'
Source WIN32_API.
If I understand correctly, problem is that the numbers do not always match the "real" hex numbers for ASCII.
I want to use an InputBox for checking password.
If the user presses "OK" without data entry, the InputBox should run again, and if the user pressed "Cancel" or "ESC", corporate subroutine have exit.
How can I recognize "ESC" or "Cancel" input, different from just "null" or empty?
And how specially do that for my customize created Input box with API, so for changing key-pressed shown as "*" in password input, named as InputBoxDk:
'API functions to be used
Private Declare Function CallNextHookEx _
Lib "user32" ( _
ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal wParam As Long, _
lParam As Any) _
As Long
Private Declare Function GetModuleHandle _
Lib "kernel32" _
Alias "GetModuleHandleA" ( _
ByVal lpModuleName As String) _
As Long
Private Declare Function SetWindowsHookEx _
Lib "user32" _
Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) _
As Long
Private Declare Function UnhookWindowsHookEx _
Lib "user32" ( _
ByVal hHook As Long) _
As Long
Private Declare Function SendDlgItemMessage _
Lib "user32" Alias "SendDlgItemMessageA" ( _
ByVal hDlg As Long, _
ByVal nIDDlgItem As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) _
As Long
Private Declare Function GetClassName _
Lib "user32" _
Alias "GetClassNameA" ( _
ByVal hWnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) _
As Long
Private Declare Function GetCurrentThreadId _
Lib "kernel32" () _
As Long
Private Declare Sub sapiSleep Lib "kernel32" _
Alias "Sleep" _
(ByVal dwMilliseconds As Long)
'Constants to be used in our API functions
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0
Private hHook As Long
Public Function NewProc(ByVal lngCode As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim RetVal
Dim strClassName As String, lngBuffer As Long
If lngCode < HC_ACTION Then
NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
Exit Function
End If
strClassName = String$(256, " ")
lngBuffer = 255
If lngCode = HCBT_ACTIVATE Then 'A window has been activated
RetVal = GetClassName(wParam, strClassName, lngBuffer)
If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox
'This changes the edit control so that it display the password character *.
'You can change the Asc("*") as you please.
SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
End If
End If
'This line will ensure that any other hooks that may be in place are
'called correctly.
CallNextHookEx hHook, lngCode, wParam, lParam
End Function
'// Make it public = avail to ALL Modules
'// Lets simulate the VBA Input Function
Public Function InputBoxDK(Prompt As String, Optional Title As String, _
Optional Default As String, _
Optional Xpos As Long, _
Optional Ypos As Long, _
Optional Helpfile As String, _
Optional Context As Long) As String
Dim lngModHwnd As Long, lngThreadID As Long
'// Lets handle any Errors JIC! due to HookProc> App hang!
On Error GoTo ExitProperly
lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)
hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
If Xpos Then
InputBoxDK = InputBox(Prompt, Title, Default, Xpos, Ypos, Helpfile, Context)
Else
InputBoxDK = InputBox(Prompt, Title, Default, , , Helpfile, Context)
End If
ExitProperly:
UnhookWindowsHookEx hHook
End Function
Sub TestDKInputBox()
Dim x
x = InputBoxDK("Type your password here.", "Password Required")
If x = "" Then End
If x <> "yourpassword" Then
MsgBox "You didn't enter a correct password."
End
End If
MsgBox "Welcome Creator!", vbExclamation
End Sub
Code reference: http://www.ozgrid.com
The Application.InputBox() returns False on Cancel or Esc, where InputBox() returns "".
Sub ProcedureName()
Dim response As Variant
Do Until Len(Trim(response)) > 0
response = Application.InputBox("Type something: ", "InputBox")
Loop
If response = vbFalse Then ' in case the use press "Cancel"
MsgBox "Pressed Cancel"
End If
End Sub
InputBox("prompt", "title", "default")
I can't test it, but If the user clicks OK the result should be "default". If something else is clicked the result should be "". If the user clears the input and clicks OK, the result is "" too. There is no way to make sure that OK was clicked in a InputBox, so you might need a custom UserForm for that.
How can I recognize "ESC" or "Cancel" input, different from just "null" or empty?
It's not quite documented, but a cancelled inputbox does not return just any "" empty string:
Debug.Print StrPtr("") ' returns some address
Debug.Print StrPtr(vbNullString) ' returns 0
The problem is that comparing vbNullString with "" will return True.
So the trick is to validate the StrPtr of the returned value:
Dim result As String
result = InputBox(...)
If StrPtr(result) = 0 Then
' definitely cancelled
Exit Sub
End If
If result = vbNullString Then
' legit empty string
'...
Else
' non-empty string
'...
End If
This solution works in VB6, as well as in any VBA host.
I have been using the standard password textbox written by Daniel Klann (http://www.ozgrid.com/forum/showthread.php?t=72794) to hide the password inputs.
The main problem is that the standard InputBox returns empty fields and cancel the same way. Application.InputBox however is capable of returning a False on cancel.
Updating Daniel Klann's script to work with the Application.InputBox is beyond me. How would this be done?
Here is Daniel's code:
Option Explicit
'////////////////////////////////////////////////////////////////////
'Password masked inputbox
'Allows you to hide characters entered in a VBA Inputbox.
'
'Code written by Daniel Klann
'http://www.danielklann.com/
'March 2003
'// Kindly permitted to be amended
'// Amended by Ivan F Moala
'// http://www.xcelfiles.com
'// April 2003
'// Works for Xl2000+ due the AddressOf Operator
'////////////////////////////////////////////////////////////////////
'******************** CALL FROM FORM *********************************
' Dim pwd As String
'
' pwd = InputBoxDK("Please Enter Password Below!", "Database Administration Security Form.")
'
' 'If no password was entered.
' If pwd = "" Then
' MsgBox "You didn't enter a password! You must enter password to 'enter the Administration Screen!" _
' , vbInformation, "Security Warning"
' End If
'**************************************
'API functions to be used
Private Declare Function CallNextHookEx _
Lib "user32" ( _
ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal wParam As Long, _
lParam As Any) _
As Long
Private Declare Function GetModuleHandle _
Lib "kernel32" _
Alias "GetModuleHandleA" ( _
ByVal lpModuleName As String) _
As Long
Private Declare Function SetWindowsHookEx _
Lib "user32" _
Alias "SetWindowsHookExA" ( _
ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) _
As Long
Private Declare Function UnhookWindowsHookEx _
Lib "user32" ( _
ByVal hHook As Long) _
As Long
Private Declare Function SendDlgItemMessage _
Lib "user32" Alias "SendDlgItemMessageA" ( _
ByVal hDlg As Long, _
ByVal nIDDlgItem As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) _
As Long
Private Declare Function GetClassName _
Lib "user32" _
Alias "GetClassNameA" ( _
ByVal hWnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) _
As Long
Private Declare Function GetCurrentThreadId _
Lib "kernel32" () _
As Long
'Constants to be used in our API functions
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0
Private hHook As Long
Public Function NewProc(ByVal lngCode As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim RetVal
Dim strClassName As String, lngBuffer As Long
If lngCode < HC_ACTION Then
NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
Exit Function
End If
strClassName = String$(256, " ")
lngBuffer = 255
If lngCode = HCBT_ACTIVATE Then 'A window has been activated
RetVal = GetClassName(wParam, strClassName, lngBuffer)
If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox
'This changes the edit control so that it display the password character *.
'You can change the Asc("*") as you please.
SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
End If
End If
'This line will ensure that any other hooks that may be in place are
'called correctly.
CallNextHookEx hHook, lngCode, wParam, lParam
End Function
'// Make it public = avail to ALL Modules
'// Lets simulate the VBA Input Function
Public Function InputBoxDK(Prompt As String, Optional Title As String, _
Optional Default As String, _
Optional Xpos As Long, _
Optional Ypos As Long, _
Optional Helpfile As String, _
Optional Context As Long) As String
Dim lngModHwnd As Long, lngThreadID As Long
'// Lets handle any Errors JIC! due to HookProc> App hang!
On Error Goto ExitProperly
lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)
hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
If Xpos Then
InputBoxDK = InputBox(Prompt, Title, Default, Xpos, Ypos, Helpfile, Context)
Else
InputBoxDK = InputBox(Prompt, Title, Default, , , Helpfile, Context)
End If
ExitProperly:
UnhookWindowsHookEx hHook
End Function
the standard InputBox returns empty fields and cancel the same way
No it does not. It returns a null pointer (vbNullString) on cancel and an empty string ("") for empty input.
Dim s As String
s = InputBox("Test")
If StrPtr(s) = 0 Then
'Cancel pressed
Else
'Ok pressed
End If
Because InputBoxDK returns the InputBox's value unchanged, same logic applies to it.
This used to work last week. I suspect a Windows update broke something. When using ShellExecute, it is forcing the URLs into lowercase, breaking parameter values passed to a case-sensitive server!
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
Optional ByVal lpParameters As String, _
Optional ByVal lpDirectory As String, _
Optional ByVal nShowCmd As Long _
) As Long
Sub OpenBrowser()
Let RetVal = ShellExecute(0, "open", "http://yaHOO.com?UPPERCASE=lowercase")
Will open http://www.yahoo.com/?uppercase=lowercase
Version
I'm using Windows 8.1. I tried it in 3 browsers. Lowercase in Chrome, lowercase in IE, and Opera chops off the query parameter, but the host is lowercase.
Ok I solved it by creating a temporary HTML file, finding the executable associated with that, then launching the executable directly with the URL. Sheesh.
Private Const SW_SHOW = 5 ' Displays Window in its current size and position
Private Const SW_SHOWNORMAL = 1 ' Restores Window if Minimized or Maximized
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
Optional ByVal lpParameters As String, _
Optional ByVal lpDirectory As String, _
Optional ByVal nShowCmd As Long _
) As Long
Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" ( _
ByVal lpFile As String, _
ByVal lpDirectory As String, _
ByVal lpResult As String _
) As Long
Private Declare Function GetTempPath Lib "kernel32" _
Alias "GetTempPathA" ( _
ByVal nBufferLength As Long, _
ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileName Lib "kernel32" _
Alias "GetTempFileNameA" ( _
ByVal lpszPath As String, _
ByVal lpPrefixString As String, _
ByVal wUnique As Long, _
ByVal lpTempFileName As String) As Long
Public Function GetTempFileNameVBA( _
Optional sPrefix As String = "VBA", _
Optional sExtensao As String = "") As String
Dim sTmpPath As String * 512
Dim sTmpName As String * 576
Dim nRet As Long
Dim F As String
nRet = GetTempPath(512, sTmpPath)
If (nRet > 0 And nRet < 512) Then
nRet = GetTempFileName(sTmpPath, sPrefix, 0, sTmpName)
If nRet <> 0 Then F = Left$(sTmpName, InStr(sTmpName, vbNullChar) - 1)
If sExtensao > "" Then
Kill F
If Right(F, 4) = ".tmp" Then F = Left(F, Len(F) - 4)
F = F & sExtensao
End If
GetTempFileNameVBA = F
End If
End Function
Sub Test_GetTempFileNameVBA()
Debug.Print GetTempFileNameVBA("BR", ".html")
End Sub
Private Sub LaunchBrowser()
Dim FileName As String, Dummy As String
Dim BrowserExec As String * 255
Dim RetVal As Long
Dim FileNumber As Integer
FileName = GetTempFileNameVBA("BR", ".html")
FileNumber = FreeFile ' Get unused file number
Open FileName For Output As #FileNumber ' Create temp HTML file
Write #FileNumber, "<HTML> <\HTML>" ' Output text
Close #FileNumber ' Close file
' Then find the application associated with it
RetVal = FindExecutable(FileName, Dummy, BrowserExec)
Kill FileName ' delete temp HTML file
BrowserExec = Trim(BrowserExec)
' If an application is found, launch it!
If RetVal <= 32 Or IsEmpty(BrowserExec) Then ' Error
MsgBox "Could not find associated Browser", vbExclamation, "Browser Not Found"
Else
RetVal = ShellExecute(0, "open", BrowserExec, "http://www.yaHOO.com?case=MATTERS", Dummy, SW_SHOWNORMAL)
If RetVal <= 32 Then ' Error
MsgBox "Web Page not Opened", vbExclamation, "URL Failed"
End If
End If
End Sub
Use FileProtocolHandler instead of ShellExecute:
Public Declare Function FileProtocolHandler Lib "url.dll" _
Alias "FileProtocolHandlerA" (ByVal hwnd As Long, ByVal hinst As Long, _
ByVal lpszCmdLine As String, ByVal nShowCmd As Long) As Long
Public Sub OpenHyperlink(ByVal Url)
FileProtocolHandler 0, 0, Url, 1
End Sub
With FileProtocolHandler, the lowercase conversion does not occur.
I have this problem under Windows 8.1, but not under Windows 7.
In my case using a temp ".html" file wasn't an option because those are linked to gedit so i can edit them.
I can't say if it works on the domain part, but i needed case sensitivity for the GET parameters.
I accomplished that by simple encoding everything in hex. Not just characters like "/" but everything.