How do I open an HTML page in the default browser with VBA? I know it's something like:
Shell "http://myHtmlPage.com"
But I think I have to reference the program which will open the page.
You can use the Windows API function ShellExecute to do so:
Option Explicit
Private Declare Function ShellExecute _
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 = vbMinimizedFocus _
) As Long
Public Sub OpenUrl()
Dim lSuccess As Long
lSuccess = ShellExecute(0, "Open", "www.google.com")
End Sub
As given in comment, to make it work in 64-bit, you need add PtrSafe in the Private Declare Line as shown below:
Private Declare PtrSafe Function ShellExecute _
Just a short remark concerning security: If the URL comes from user input make sure to strictly validate that input as ShellExecute would execute any command with the user's permissions, also a format c: would be executed if the user is an administrator.
You can even say:
FollowHyperlink "www.google.com"
If you get Automation Error then use http://:
ThisWorkbook.FollowHyperlink("http://www.google.com")
If you want a more robust solution with ShellExecute that will open ANY file, folder or URL using the default OS associated program to do so, here is a function taken from http://access.mvps.org/access/api/api0018.htm:
'************ Code Start **********
' This code was originally written by Dev Ashish.
' It is not to be altered or distributed,
' except as part of an application.
' You are free to use it in any application,
' provided the copyright notice is left unchanged.
'
' Code Courtesy of
' Dev Ashish
'
Private 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
'***App Window Constants***
Public Const WIN_NORMAL = 1 'Open Normal
Public Const WIN_MAX = 3 'Open Maximized
Public Const WIN_MIN = 2 'Open Minimized
'***Error Codes***
Private Const ERROR_SUCCESS = 32&
Private Const ERROR_NO_ASSOC = 31&
Private Const ERROR_OUT_OF_MEM = 0&
Private Const ERROR_FILE_NOT_FOUND = 2&
Private Const ERROR_PATH_NOT_FOUND = 3&
Private Const ERROR_BAD_FORMAT = 11&
'***************Usage Examples***********************
'Open a folder: ?fHandleFile("C:\TEMP\",WIN_NORMAL)
'Call Email app: ?fHandleFile("mailto:dash10#hotmail.com",WIN_NORMAL)
'Open URL: ?fHandleFile("http://home.att.net/~dashish", WIN_NORMAL)
'Handle Unknown extensions (call Open With Dialog):
' ?fHandleFile("C:\TEMP\TestThis",Win_Normal)
'Start Access instance:
' ?fHandleFile("I:\mdbs\CodeNStuff.mdb", Win_NORMAL)
'****************************************************
Function fHandleFile(stFile As String, lShowHow As Long)
Dim lRet As Long, varTaskID As Variant
Dim stRet As String
'First try ShellExecute
lRet = apiShellExecute(hWndAccessApp, vbNullString, _
stFile, vbNullString, vbNullString, lShowHow)
If lRet > ERROR_SUCCESS Then
stRet = vbNullString
lRet = -1
Else
Select Case lRet
Case ERROR_NO_ASSOC:
'Try the OpenWith dialog
varTaskID = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " _
& stFile, WIN_NORMAL)
lRet = (varTaskID <> 0)
Case ERROR_OUT_OF_MEM:
stRet = "Error: Out of Memory/Resources. Couldn't Execute!"
Case ERROR_FILE_NOT_FOUND:
stRet = "Error: File not found. Couldn't Execute!"
Case ERROR_PATH_NOT_FOUND:
stRet = "Error: Path not found. Couldn't Execute!"
Case ERROR_BAD_FORMAT:
stRet = "Error: Bad File Format. Couldn't Execute!"
Case Else:
End Select
End If
fHandleFile = lRet & _
IIf(stRet = "", vbNullString, ", " & stRet)
End Function
'************ Code End **********
Just put this into a separate module and call fHandleFile() with the right parameters.
I find the most simple is
shell "explorer.exe URL"
This also works to open local folders.
You need to call ShellExecute.
Related
So I used the following code to open a Hyperlink from an email. This hyperlink opens the webpage and opens the download window to choose where to download a CSV and with what name (all of this is in Chrome). I want to be able to choose where said file will be downloaded and with what name. I would really appreciate the help :)
Private Declare PtrSafe Function ShellExecute _
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 = vbMinimizedFocus _
) As Long
Public Sub OpenLinks(olMail As Outlook.MailItem)
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim strURL As String
Dim lSuccess As Long
Set Reg1 = New RegExp
With Reg1
.Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$%;_])*)>"
.Global = False
.IgnoreCase = True
End With
If Reg1.Test(olMail.Body) Then
Set M1 = Reg1.Execute(olMail.Body)
For Each M In M1
strURL = M.SubMatches(0)
Debug.Print strURL
lSuccess = ShellExecute(0, "Open", strURL)
Next
End If
Set Reg1 = Nothing
Set oApp = Nothing
End Sub
I've looked in other sites, but couldn't find anything similar.
You can choose one of the following ways:
Use Windows API, see the URLDownloadToFile function:
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then
If Dir(LocalFileName) <> vbNullString Then
DownloadFile = True
End If
End If
End Function
Private Sub Form_Load()
If Not DownloadFile("http://www.test.come", "c:\\file.doc") Then
MsgBox "Unable to download the file, or the source URL doesn't exist."
End If
End Sub
Click buttons programmatically using Windows API functions, see VBA - Go to website and download file from save prompt for more infromation.
On pressing a Save button on a form, I would like to run a Timed Message Box that closes automatically after 1 second. The default MsgBox command does not disappear until user presses OK or Exit.
So far, I have a solution from online search:
Public Sub Timed_Box (dur AS Long)
Dim WSH AS IWshRuntimeLibrary.WshShell
Dim Res AS Long
Set WSH = IWshRuntimeLibrary.WshShell
Res = WSH.PopUp(Text:="Record Updated", secondstowait:=dur, _
Title:="Update", Type:=vbOKOnly)
End Sub
It works fine. However, the problem is that it creates a temporary Window on desktop Taskbar for the duration which is quite annoying for a user to see. Is there anyway, I can hide this window from appearing on taskbar while still display message similar to MsgBox?
I wrote an additional answer instead of just a comment, because it seems to be too important to the requested context.
Lone wrote regarding MatteoNNZ's answer:
Thanks for sharing, the result is no different from what I am achieving with my existing code. Your code also produced a Temporary Window on taskbar.
But it's just a small step away from your needs!
Just provide the handle of your Microsoft Access Window (Application.hWndAccessApp) to the Api to let the resulting message box be 'visually bound' to Microsoft Access:
MsgBoxTimeout Application.hWndAccessApp, "This message box will be closed after 1 second ", "Automatically closing MsgBox", vbInformation, 0, 1000
Update 2019-04-05
Here is a wrapper for the MessageBoxTimeout to simplify the calling.
The order of the parameters and their default values follow the original MsgBox function.
It uses the original API function namens to free this name for the user defined procedure.
I added an enumeration for the timeout return value 32000.
You should take care to add proper error handling.
#If VBA7 Then
Private Declare PtrSafe Function MessageBoxTimeoutA Lib "user32" (ByVal hwnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As VbMsgBoxStyle, ByVal wlange As Long, ByVal dwTimeout As Long) As Long
#Else
Private Declare Function MsgBoxTimeout Lib "user32" Alias "MessageBoxTimeoutA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As VbMsgBoxStyle, ByVal wlange As Long, ByVal dwTimeout As Long) As Long
#End If
Public Enum VbMsgBoxTimeoutResult
Timeout = 32000
End Enum
'// If parameter msgTimeoutMilliseconds < 1 then the message box will not close by itself.
'// There is one additional return value to the values of VbMsgBoxResult:
'// If the message box timed out it returns 32000 (VbMsgBoxTimeoutResult.Timeout).
Public Function MsgBoxTimeout(ByVal msgText As String, Optional ByVal msgButtons As VbMsgBoxStyle = vbOKOnly, Optional ByVal msgTitle As String = vbNullString, Optional ByVal msgTimeoutMilliseconds As Long = 0) As VbMsgBoxResult
MsgBoxTimeout = MessageBoxTimeoutA(Application.hWndAccessApp, msgText, msgTitle, msgButtons, 0, msgTimeoutMilliseconds)
End Function
An usage example:
Select Case MsgBoxTimeout("Foo", vbYesNo + vbQuestion, "Bar", 5000)
Case VbMsgBoxTimeoutResult.Timeout
Debug.Print "MessageBox timed out."
Case vbYes
Debug.Print "User selected 'Yes'."
Case Else
Debug.Print "User selected 'No'."
End Select
An option is to create your own messagebox. This you can open with a timeout:
' API call for sleep function.
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Function OpenFormDialog( _
ByVal FormName As String, _
Optional ByVal TimeOut As Long, _
Optional ByVal OpenArgs As Variant = Null) _
As Boolean
' Open a modal form in non-dialogue mode to prevent dialogue borders to be displayed
' while simulating dialogue behaviour using Sleep.
' If TimeOut is negative, zero, or missing:
' Form FormName waits forever.
' If TimeOut is positive:
' Form FormName exits after TimeOut milliseconds.
Const SecondsPerDay As Single = 86400
Dim LaunchTime As Date
Dim CurrentTime As Date
Dim TimedOut As Boolean
Dim Index As Integer
Dim FormExists As Boolean
' Check that form FormName exists.
For Index = 0 To CurrentProject.AllForms.Count - 1
If CurrentProject.AllForms(Index).Name = FormName Then
FormExists = True
Exit For
End If
Next
If FormExists = True Then
If CurrentProject.AllForms(FormName).IsLoaded = True Then
' Don't reopen the form should it already be loaded.
Else
' Open modal form in non-dialogue mode to prevent dialogue borders to be displayed.
DoCmd.OpenForm FormName, acNormal, , , , acWindowNormal, OpenArgs
End If
' Record launch time and current time with 1/18 second resolution.
LaunchTime = Date + CDate(Timer / SecondsPerDay)
Do While CurrentProject.AllForms(FormName).IsLoaded
' Form FormName is open.
' Make sure form and form actions are rendered.
DoEvents
' Halt Access for 1/20 second.
' This will typically cause a CPU load less than 1%.
' Looping faster will raise CPU load dramatically.
Sleep 50
If TimeOut > 0 Then
' Check for time-out.
CurrentTime = Date + CDate(Timer / SecondsPerDay)
If (CurrentTime - LaunchTime) * SecondsPerDay > TimeOut / 1000 Then
' Time-out reached.
' Close form FormName and exit.
DoCmd.Close acForm, FormName, acSaveNo
TimedOut = True
Exit Do
End If
End If
Loop
' At this point, user or time-out has closed form FormName.
End If
' Return True if the form was not found or was closed by user interaction.
OpenFormDialog = Not TimedOut
End Function
It does, however, take a lot more code to obtain the full functionality of a messagebox, but it is carefully described and for download in my article:
Modern/Metro style message box and input box for Microsoft Access 2013+
Code is also at GitHub: VBA.ModernBox
You can use the MsgBoxTimeout function provided in the library user32 of Windows.
Declare the following on top of your module:
#If Win64 Then 'If the system is in 64b
Private Declare PtrSafe Function MsgBoxTimeout _
Lib "user32" _
Alias "MessageBoxTimeoutA" ( _
ByVal hwnd As LongPtr, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As VbMsgBoxStyle, _
ByVal wlange As Long, _
ByVal dwTimeout As Long) _
As Long
#Else 'if it's in 32b
Private Declare Function MsgBoxTimeout _
Lib "user32" _
Alias "MessageBoxTimeoutA" ( _
ByVal hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As VbMsgBoxStyle, _
ByVal wlange As Long, _
ByVal dwTimeout As Long) _
As Long
#End If
Then use it like this:
MsgBoxTimeout 0, "This message box will be closed after 1 second ", "Automatically closing MsgBox", vbInformation, 0, 1000
Some useful notes:
The #If Win64 Then part is a macro determining at compile time what declaration to use. In 64b systems, in fact, every function declared by an external library should use the PtrSafe (pointer-safe) keyword which doesn't exist in 32b systems.
You pass the timeout in milliseconds, that's why the parameter is 1000 when you want it to wait 1 second.
Here is my wrapper for MessageBoxTimeout to simplify the call. Instead of returning timeout information, I needed to return the default button value. The order of parameters and default values follows the original MsgBox function for better use.
Option Compare Database
#If VBA7 Then
Private Declare PtrSafe Function MessageBoxTimeoutA Lib "user32" (ByVal hwnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As VbMsgBoxStyle, ByVal wlange As Long, ByVal dwTimeout As Long) As Long
#Else
Private Declare Function MsgBoxTimeout Lib "user32" Alias "MessageBoxTimeoutA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As VbMsgBoxStyle, ByVal wlange As Long, ByVal dwTimeout As Long) As Long
#End If
Public Enum vbMsgBoxTimeoutResult
vbTimeout = 32000
End Enum
'// If parameter msgTimeoutMilliseconds < 1 then the message box will not close by itself.
'// The default timeout is set to 15 sec
'//
Public Function MsgBoxTimeout(ByVal msgText As String, Optional ByVal msgButtons As VbMsgBoxStyle = vbOKOnly, Optional ByVal msgTitle As String = vbNullString, Optional ByVal msgTimeoutMilliseconds As Long = 15000) As VbMsgBoxResult
'Always set minimal timeout to 1 sec
If msgTimeoutMilliseconds < 1000 Then msgTimeoutMilliseconds = 1000
MsgBoxTimeout = MessageBoxTimeoutA(Application.hWndAccessApp, msgText, msgTitle, msgButtons, 0, msgTimeoutMilliseconds)
'timeout action
If MsgBoxTimeout = VbMsgBoxTimeoutResult_Timeout Then
Dim defaultButtonFlag
'get default button
defaultButtonFlag = vbDefaultButton1
If msgButtons And vbDefaultButton4 Then defaultButtonFlag = vbDefaultButton4
If msgButtons And vbDefaultButton3 Then defaultButtonFlag = vbDefaultButton3
If msgButtons And vbDefaultButton2 Then defaultButtonFlag = vbDefaultButton2
'get only buttons information
msgButtons = msgButtons And 7
'return default value
If msgButtons = vbYesNo Then
If defaultButtonFlag = vbDefaultButton2 Then
MsgBoxTimeout = vbNo
Else
MsgBoxTimeout = vbYes
End If
ElseIf msgButtons = vbYesNoCancel Then
If defaultButtonFlag = vbDefaultButton3 Then
MsgBoxTimeout = vbCancel
ElseIf defaultButtonFlag = vbDefaultButton2 Then
MsgBoxTimeout = vbNo
Else
MsgBoxTimeout = vbYes
End If
ElseIf msgButtons = vbAbortRetryIgnore Then
If defaultButtonFlag = vbDefaultButton3 Then
MsgBoxTimeout = vbIgnore
ElseIf defaultButtonFlag = vbDefaultButton2 Then
MsgBoxTimeout = vbRetry
Else
MsgBoxTimeout = vbAbort
End If
ElseIf msgButtons = vbOKCancel Then
If defaultButtonFlag = vbDefaultButton2 Then
MsgBoxTimeout = vbCancel
Else
MsgBoxTimeout = vbOK
End If
ElseIf msgButtons = vbOKOnly Then
MsgBoxTimeout = vbOK
Else
'do nothing, already MsgBoxTimeout = vbMsgBoxTimeoutResult.vbTimeout
End If
End If
End Function
Is there a 64bit version of the Function DeviceCapabilities in the winspool.drv library? What I'm looking for is a conversion of:
Private Declare Function DeviceCapabilities Lib "winspool.drv" _
Alias "DeviceCapabilitiesA" (ByVal lpDeviceName As String, _
ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, _
ByVal dev As Long) As Long
Clearly I change Declare Function to Declare PtrSafe Function but which of the Long variable change and do they change to LongLong or LongPtr? Strange that a trawl of the internet over the last hour hasn't turned up any reference to this?
Programmatically retrieve printer capabilities
I modified this linked code in Microsoft Access to work with 64-bit.
And, by executing Reference Setting "Microsoft ACCESS XX.0 Object Library", I modified the following code to work in Microsoft Excel.
However, the following code is one different: That is the original code
For lngCounter = 1 To lngPaperCount
However, this code will cause an error.
The occurrence of this error is avoided by performing minus one.
For lngCounter = 1 To lngPaperCount -1
You may think such a following code, but code will cause an error, too.
For lngCounter = 0 To lngPaperCount
I don't know if my printer is causing the error or my 64bit Microsoft Office is causing the error.
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function DeviceCapabilities Lib "winspool.drv" _
Alias "DeviceCapabilitiesA" (ByVal lpsDeviceName As String, _
ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, _
ByVal lpDevMode As Long) As Long
#Else
' Declaration for the DeviceCapabilities function API call.
Private Declare Function DeviceCapabilities Lib "winspool.drv" _
Alias "DeviceCapabilitiesA" (ByVal lpsDeviceName As String, _
ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, _
ByVal lpDevMode As Long) As Long
#End If
' DeviceCapabilities function constants.
Private Const DC_PAPERNAMES = 16
Private Const DC_PAPERS = 2
Private Const DC_BINNAMES = 12
Private Const DC_BINS = 6
Private Const DEFAULT_VALUES = 0
Sub GetPaperList()
Dim lngPaperCount As Long
Dim lngCounter As Long
Dim hPrinter As Long
Dim strDeviceName As String
Dim strDevicePort As String
Dim strPaperNamesList As String
Dim strPaperName As String
Dim intLength As Integer
Dim strMsg As String
Dim aintNumPaper() As Integer
On Error GoTo GetPaperList_Err
' Get the name and port of the default printer.
strDeviceName = Access.Application.Printer.DeviceName
strDevicePort = Access.Application.Printer.Port
' Get the count of paper names supported by the printer.
lngPaperCount = DeviceCapabilities(lpsDeviceName:=strDeviceName, _
lpPort:=strDevicePort, _
iIndex:=DC_PAPERNAMES, _
lpOutput:=ByVal vbNullString, _
lpDevMode:=DEFAULT_VALUES)
' Re-dimension the array to the count of paper names.
ReDim aintNumPaper(1 To lngPaperCount)
' Pad the variable to accept 64 bytes for each paper name.
strPaperNamesList = String(64 * lngPaperCount, 0)
' Get the string buffer of all paper names supported by the printer.
lngPaperCount = DeviceCapabilities(lpsDeviceName:=strDeviceName, _
lpPort:=strDevicePort, _
iIndex:=DC_PAPERNAMES, _
lpOutput:=ByVal strPaperNamesList, _
lpDevMode:=DEFAULT_VALUES)
' Get the array of all paper numbers supported by the printer.
lngPaperCount = DeviceCapabilities(lpsDeviceName:=strDeviceName, _
lpPort:=strDevicePort, _
iIndex:=DC_PAPERS, _
lpOutput:=aintNumPaper(1), _
lpDevMode:=DEFAULT_VALUES)
' List the available paper names.
strMsg = "Papers available for " & strDeviceName & vbCrLf
For lngCounter = 1 To lngPaperCount
' Parse a paper name from the string buffer.
strPaperName = VBA.Mid(String:=strPaperNamesList, _
Start:=64 * (lngCounter - 1) + 1, Length:=64)
intLength = VBA.InStr(Start:=1, String1:=strPaperName, String2:=Chr(0)) - 1
strPaperName = VBA.Left(String:=strPaperName, Length:=intLength)
' Add a paper number and name to text string for the message box.
strMsg = strMsg & vbCrLf & aintNumPaper(lngCounter) _
& vbTab & strPaperName
Next lngCounter
' Show the paper names in a message box.
MsgBox Prompt:=strMsg
GetPaperList_End:
Exit Sub
GetPaperList_Err:
MsgBox Prompt:=Err.Description, Buttons:=vbCritical & vbOKOnly, _
Title:="Error Number " & Err.Number & " Occurred"
Resume GetPaperList_End
End Sub
I have now used the above function by declaring as follows:
Private Declare PtrSafe Function DeviceCapabilities Lib "winspool.drv" _
Alias "DeviceCapabilitiesA" (ByVal lpDeviceName As String, _
ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, _
ByVal dev As Long) As Long
For the function to work the API code line
sCurrentPrinter = Trim$(Left$(ActivePrinter, InStr(ActivePrinter, " on ")))
needs to be changed to
sCurrentPrinter = ActivePrinter
I am using the below vba code to open a putty screen on a button click.
TaskID = Shell("C:\putty.exe 173.194.127.210", vbMaximizedFocus)
When it opens a new screen, the title bar will contain the string "173.194.127.210 - PUTTY".
I want to change "173.194.127.210 - PUTTY" to "173.194.127.210 - HELLO" through vba code when the above code opens a new screen. Can anyone share the code for doing this?
Please note that I am not using super putty.
I am able to do the same manually with following steps:
Right click on title bar of putty screen opened.
Click on change settings
Click on Behavior under the option Window
Change window title as 173.194.127.210 - HELLO
Unfortunately, there is no way to change this value via the command line. The only place that this value can be set is in a session. Look at the PuTTY Configuration page, and click on the Session branch to see this. There is always a session called "Default Settings" which can't be deleted, and simply shows the application's internal defaults. You can't change these. However, you can create a new session programatically, save the window title in that, and then use the "-load" option of the PuTTY command line to load that session when starting the application.
This information for sessions is stored in the registry for each user, under the HKEY_CURRENT_USER\Software\SimonTatham\PuTTY\Sessions key. Each key under here becomes a session with the name of the key. For the purposes of creating a session name which is unlikely to clash with a user's session, the code below uses a name which is the application EXE name, prefixed by two underscores.
The registry value you need to write for the window title is "WinTitle". However, you must also provide the "HostName", "Protocol" and "Port" values for PuTTY to open correctly. All values except "Port" are string (REG_SZ), whilst "Port" is an integer (REG_DWORD).
Option Explicit
Private Const HKEY_CURRENT_USER As Long = &H80000001
Private Const ERROR_SUCCESS As Long = 0&
Private Const REG_SZ As Long = 1
Private Const REG_DWORD As Long = 4
Private Enum REGSAM
KEY_ALL_ACCESS = &HF003F
KEY_CREATE_LINK = &H20
KEY_CREATE_SUB_KEY = &H4
KEY_ENUMERATE_SUB_KEYS = &H8
KEY_EXECUTE = &H20019
KEY_NOTIFY = &H10
KEY_QUERY_VALUE = &H1
KEY_READ = &H20019
KEY_SET_VALUE = &H2
KEY_WOW64_32KEY = &H200
KEY_WOW64_64KEY = &H100
KEY_WRITE = &H20006
End Enum
Private Declare Function RegCloseKey Lib "Advapi32.dll" ( _
ByVal hKey As Long _
) As Long
Private Declare Function RegCreateKeyEx Lib "Advapi32.dll" Alias "RegCreateKeyExW" ( _
ByVal hKey As Long, _
ByVal lpSubKey As Long, _
ByVal Reserved As Long, _
ByVal lpClass As Long, _
ByVal dwOptions As Long, _
ByVal samDesired As REGSAM, _
ByVal lpSecurityAttributes As Long, _
ByRef phkResult As Long, _
ByRef lpdwDisposition As Long _
) As Long
Private Declare Function RegSetValueEx Lib "Advapi32.dll" Alias "RegSetValueExW" ( _
ByVal hKey As Long, _
ByVal lpValueName As Long, _
ByVal Reserved As Long, _
ByVal dwType As Long, _
ByVal lpData As Long, _
ByVal cbData As Long _
) As Long
Private Enum ConnectionType
Raw
Telnet
Rlogin
SSH
End Enum
Private Function OpenPutty(ByRef the_sHost As String, ByRef the_sTitle As String, ByVal enmConnectionType As ConnectionType, Optional ByVal the_nPort = -1) As Long
Dim sUniqueSession As String
Dim sKeyUniqueSession As String
Dim sConnectionType As String
Dim nPort As Long
Dim hKeyUniqueSession As Long
sUniqueSession = "__" & App.EXEName
sKeyUniqueSession = "Software\SimonTatham\PuTTY\Sessions\" & sUniqueSession
' Provide the connection type / protocol string, and a default port value.
Select Case enmConnectionType
Case Raw
sConnectionType = "raw"
nPort = -1
Case Telnet
sConnectionType = "telnet"
nPort = 23
Case Rlogin
sConnectionType = "rlogin"
nPort = 513
Case SSH
sConnectionType = "ssh"
nPort = 22
End Select
' -1 indicates use the default port value.
If the_nPort <> -1 Then
nPort = the_nPort
End If
If RegCreateKeyEx(HKEY_CURRENT_USER, StrPtr(sKeyUniqueSession), 0&, 0&, 0&, KEY_SET_VALUE, 0&, hKeyUniqueSession, 0&) = ERROR_SUCCESS Then
RegSetValueEx hKeyUniqueSession, StrPtr("HostName"), 0&, REG_SZ, StrPtr(the_sHost), LenB(the_sHost)
RegSetValueEx hKeyUniqueSession, StrPtr("WinTitle"), 0&, REG_SZ, StrPtr(the_sTitle), LenB(the_sTitle)
RegSetValueEx hKeyUniqueSession, StrPtr("Protocol"), 0&, REG_SZ, StrPtr(sConnectionType), LenB(sConnectionType)
RegSetValueEx hKeyUniqueSession, StrPtr("PortNumber"), 0&, REG_DWORD, VarPtr(nPort), LenB(nPort)
RegCloseKey hKeyUniqueSession
End If
OpenPutty = Shell(App.Path & "\putty.exe -load """ & sUniqueSession & """", vbMaximizedFocus)
End Function
Private Sub Command1_Click()
OpenPutty "192.168.1.5", "My custom title", Telnet
End Sub
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Sub Main()
On Error Resume Next
hwindows = FindWindow(vbNullString, "Microsoft Works Calendar")
Ret = SetWindowText(hwindows, "Calandar")
End Sub
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.