SFTP upload in VBA - vba

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)

Related

FtpFindFirstFile always returns zero

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

Macro VBA Code Shell Invalad procedure call or argument

I am trying to make a macro that download and execute file. Here's the code:
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
Sub AAA()
Dim SourceName As String
Dim Destination As String
Dim R As Long
SourceName = "http://localhost/files/pay.vbs"
Destination = "C:\users\david\ex.vbs"
R = URLDownloadToFile(0&, SourceName, Destination, 0&, 0&)
Shell "C:\users\david\ex.vbs", vbNormalFocus
End Sub
It gives me error: Invalid procedure call or argument

Send txt file to printer with Excel VBA

I have a sub that creates a .txt file and I want to print it in the default printer. How can I achieve this in VBA?
I think I need to call the ShellExecute API Function, but I did not find the correct sintax for that.
I would appreciate any help!
I found a code that do the trick:
Option Explicit
Declare Function apiShellExecute 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 nShowCmd As Long) _
As Long
Public Sub PrintFile(ByVal strPathAndFilename As String)
Call apiShellExecute(Application.hwnd, "print", strPathAndFilename, vbNullString, vbNullString, 0)
End Sub
Sub Test()
PrintFile ("C:\Test.pdf")
End Sub

VBA Password Input with Cancel Function

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.

VBA ShellExecute forces URL to lowercase

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.