copy

Sunday, 15 July 2018

Last updated: 15/07/2018, 2 min read (without the code)

Get & Set The Default Windows Printer With VBA


Introduction



Although VBA is a great language for building Office “applications”, when it comes to handling Windows devices, such as a printer, for example, things start to become difficult. The obvious reason is that the VBA was not designed for this kind of purposes. However, what if your VBA “application” needs to know how many printers are installed and available in the particular computer? What if your “application” must set the default Windows printer to “Adobe PDF”, hence, printing in a PDF file, instead of a paper?

To answer the last two questions, somebody might think to search for some old Visual Basic 6.0 code snippets. In other words, he/she might try to find solutions based on some old example. While this totally OK, the VB 6.0 solutions will probably rely on one or more Windows APIs. So, if you are not very familiar using Windows APIs in your VBA code, you might have troubles adjusting the API calls. The latter is particularly true when the Office version in which your “application” will run, is 64bit. In that case, you need to carefully "alter" the API calls so as to work in 64bit (e.g. data type conversion: the Long should become LongPtr in 64bit).

But, are there any simpler solutions? Yes, there are! If we combine the VBA with Windows Management Instrumentation (WMI) and Windows Script Host (WSH) objects we can do wonders quite easily! The VBA module that follows demonstrates several techniques that show: how somebody can get the installed printers from a computer, how to check if a printer is the default one, and, finally, how to set a particular printer to be the default one.

Note: the term “application” in the above paragraphs actually implies a solution to a given problem (e.g. a budget spreadsheet), not an application with the strict definition of the term (e.g. an executable). You can develop “real” applications using VB 6.0, as well as with other programming languages, but not with VBA.



VBA code



The code below is an entire module that contains 3 VBA functions:
  • PrinterExists: A function that checks if there is a printer installed with the given name.
  • IsDefaultPrinter: A function that checks if the given printer corresponds to the default Windows printer.
  • SetDefaultPrinter: A functions that set the given printer to be the default Windows printer.
   
Next, there are 2 macros that demonstrate how these 3 functions can be used/combined to do something useful:
  • GetInstalledPrinters: A macro that loops through all the installed printers of the computer and writes their names in the "Printers" worksheet. Moreover, it checks if each printer is the default one or not.
  • SetAsTheDefaultPrinter: A macro that sets the selected range, if it corresponds to an installed printer, to be the default Windows printer. The user must select a range within the given range of (valid) printers, and, then, run the macro.

Option Explicit
        
    '-------------------------------------------------------------------------------------------------------------------------
    'This module contains 3 functions that can help you whenever you deal with printers from VBA:
    '- PrinterExists:           Checks if there is a printer installed with the given name.
    '- IsDefaultPrinter:        Checks if the given printer corresponds to the default windows printer.
    '- SetDefaultPrinter:       Makes the given printer to be the default one.
    '
    'After these functions, there are 2 macros that demonstrate how these functions can be used to do something useful.
    'Note that the macros were adjusted to work with the specific workbook that contains the worksheet named "Printers".
    '- GetInstalledPrinters:    Loops through all the installed printers and writes their names in the "Printers" worksheet.
    '                           Moreover, it checks if each printer is the default one.
    '
    '- SetAsTheDefaultPrinter:  The user selects a range within the given range of printers and then by running the macro
    '                           the selected printer becomes the default one.
    '
    'Written By:    Christos Samaras
    'Date:          14/08/2018
    'E-mail:        xristos.samaras@gmail.com
    'Site:          https://www.myengineeringworld.net
    '-------------------------------------------------------------------------------------------------------------------------
    
Function PrinterExists(printerName As String) As Boolean
    
    'Declaring the necessary variables.
    Dim computer            As String
    Dim wmiService          As Object
    Dim installedPrinters   As Variant
    Dim printer             As Object
    
    On Error Resume Next
    
    'Check if the printer name is empty.
    If printerName = vbNullString Then Exit Function

    'Set the computer. Dot means the computer running the code.    
    computer = "."
    
    'Get the WMI object
    Set wmiService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & computer & "\root\cimv2")
    
    'Retrieve information about the installed printers (by running a query).
    Set installedPrinters = wmiService.ExecQuery("Select * from Win32_Printer")
        
    'If an error occurs in the previous step, the function should exit and return False.
    If Err.Number <> 0 Then Exit Function

    'Loop through all the installed printers. If the given name matches to any of the installed printers, exit the loop and return True.                      
    For Each printer In installedPrinters
        If UCase(printer.Name) = UCase(printerName) Then
            PrinterExists = True
            Exit Function
        End If
    Next printer
    
    On Error GoTo 0
    
End Function

Function IsDefaultPrinter(printerName As String) As Boolean
      
    'Declaring the necessary variables.
    Dim computer            As String
    Dim wmiService          As Object
    Dim installedPrinters   As Variant
    Dim printer             As Object
    
    On Error Resume Next
    
    'Check if the printer name is empty.
    If printerName = vbNullString Then Exit Function
    
    'Set the computer. Dot means the computer running the code.    
    computer = "."
    
    'Get the WMI object
    Set wmiService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & computer & "\root\cimv2")
    
    'Retrieve information about the installed printers (by running a query).
    Set installedPrinters = wmiService.ExecQuery("Select * from Win32_Printer")
        
    'If an error occurs in the previous step, the function should exit and return False.
    If Err.Number <> 0 Then Exit Function

    'Loop through all the installed printers. If the given name matches to any of the installed printers                
    'and the Default property is set to True, exit the loop and return True.
    For Each printer In installedPrinters
        If UCase(printer.Name) = UCase(printerName) And printer.Default = True Then
            IsDefaultPrinter = True
            Exit Function
        End If
    Next printer
    
    On Error GoTo 0
    
End Function

Function SetDefaultPrinter(printerName As String) As Boolean
    
    'Declaring the necessary variable.
    Dim wshNetwork As Object
    
    On Error Resume Next
    
    'Check if the printer name is empty.
    If printerName = vbNullString Then Exit Function

    'Test if the printer is already the default one. If yes, return True.    
    If IsDefaultPrinter(printerName) = True Then
        SetDefaultPrinter = True
        Exit Function
    End If
        
    'The printer is not the default one. Create the WScript.Network object.
    Set wshNetwork = CreateObject("WScript.Network")
    
    'If the WScript.Network object was not created, exit.
    If wshNetwork Is Nothing Then Exit Function

    'Set the given printer to be the default one.    
    wshNetwork.SetDefaultPrinter printerName
                
    'Release the WScript.Network object.
    Set wshNetwork = Nothing
    
    'Check (again) if after the change, the given printer is indeed the default one.
    SetDefaultPrinter = IsDefaultPrinter(printerName)
    
    On Error GoTo 0
    
End Function

Sub GetInstalledPrinters()
      
    'Declaring the necessary variables.
    Dim sht                 As Worksheet
    Dim computer            As String
    Dim wmiService          As Object
    Dim installedPrinters   As Variant
    Dim printer             As Object
    Dim i                   As Integer
    
    On Error Resume Next
    
    'Set the worksheet in which the information will be written.
    Set sht = ThisWorkbook.Worksheets("Printers")
    
    'Check if the sheet exist (there is no error).
    If Err.Number <> 0 Then
        MsgBox "The sheet does not exists!", vbCritical, "Sheet Name Error"
        Exit Sub
    End If
    
    'Clear existing data.
    Call ClearAll
    
    'Set the computer. Dot means the computer running the code.    
    computer = "."
    
    'Get the WMI object
    Set wmiService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & computer & "\root\cimv2")
    
    'Retrieve information about the installed printers (by running a query).
    Set installedPrinters = wmiService.ExecQuery("Select * from Win32_Printer")
        
    'If an error occurs in the previous step, inform the user.
    If Err.Number <> 0 Then
        MsgBox "Could not retrieve the printer information from WMI object!", vbCritical, "WMI Object Error"
        Exit Sub
    End If
              
    'Set the starting row.
    i = 5
     
    'Loop through all the installed printers and get their name. Check if one of them is the default one.
    For Each printer In installedPrinters
        
        'Write the results to the worksheet.
        sht.Range("C" & i).Value = printer.Name
        sht.Range("D" & i).Value = printer.Default
        i = i + 1
        
    Next printer
    
    On Error GoTo 0

End Sub

Sub SetAsTheDefaultPrinter()
    
    'Declaring the necessary variable.
    Dim sht     As Worksheet
    Dim rng     As Range
    
    On Error Resume Next
    
    'Set the worksheet in which the information will be written.
    Set sht = ThisWorkbook.Worksheets("Printers")
    
    'Check if the sheet exist (there is no error).
    If Err.Number <> 0 Then
        MsgBox "The sheet does not exists!", vbCritical, "Sheet Name Error"
        Exit Sub
    End If
    
    'Get the intersected range.
    Set rng = Application.Intersect(sht.Range("C5:C24"), Selection.Range("A1"))
    
    'If there is no "common" range, exit.
    If rng Is Nothing Then
        MsgBox "The selected range is outside the 'C5:C24' range!", vbCritical, "Invalid Common Range Error"
        Exit Sub
    End If
    
    'If the common range is empty, exit.
    If IsEmpty(rng) Then
        MsgBox "The range you selected is empty!", vbCritical, "Empty Range Error"
        Exit Sub
    End If
    
    'Check if the selected printer is already the default printer.
    If IsDefaultPrinter(rng.Range("A1")) Then
        MsgBox "The selected printer '" & rng.Range("A1") & "' is already the default printer!", vbExclamation, "Default Printer Warning"
        Exit Sub
    End If
    
    'Finally, set the selected printer as the default one and inform the user.
    If SetDefaultPrinter(rng.Range("A1")) = True Then
        
        'Run the GetInstalledPrinters macro to "prove" the change.
        Call GetInstalledPrinters
        
        'The process succeded.
        MsgBox "The selected printer '" & rng.Range("A1") & "' was set as the default printer!", vbInformation, "Success"
        
    Else
    
        'The process failed.
        MsgBox "It was impossible to set the selected printer '" & rng.Range("A1") & "' as the default printer!", vbCritical, "Failure"
        
    End If

End Sub

Sub ClearAll()
      
    'Declaring the necessary variable.
    Dim sht As Worksheet
    
    On Error Resume Next
    
    'Set the worksheet in which the information will be written.
    Set sht = ThisWorkbook.Worksheets("Printers")
    
    'Check if the sheet exist (there is no error).
    If Err.Number <> 0 Then
        MsgBox "The sheet does not exists!", vbCritical, "Sheet Name Error"
        Exit Sub
    End If
    
    'Clear the data.
    sht.Range("C5:D24").ClearContents
    
End Sub

Note that the two macros were adjusted to work with the specific workbook that contains a worksheet named "Printers". You can find this workbook in the Downloads section that follows.



Downloads



Download

The file can be opened with Excel 2007 or newer. Please enable macros before using it.

Saturday, 30 June 2018

Last updated: 03/07/2018, 1 min read (without the code)

Get Laptop Battery Information Through VBA


Introduction



As the title indicates, in this post we will learn how to get several properties related to the battery of the laptop that runs our VBA code. Unfortunately, VBA does not have any built-in functionality that can be used to retrieve this kind of information. Therefore, with the help of WMI we will get the following battery properties:
  • Availability
  • Battery status
  • Chemistry
  • Estimated charge remaining
  • Estimated run time
  • Time on battery
  • Time to full charge

These are probably the most useful ones. If you need other attributes, you can check this link to find the additional properties that are available in the Win32_Battery class. The technique to retrieve any of the other property is similar to the one used below.



VBA code



The code was written in a way that all the functions are based on the GetBatteryObject function, which returns an object containing several properties about the laptop's battery. The other functions simply use this object to check if a particular property exists. If yes, then they retrieve the value of that property. If the returned numeric value is an enumeration, as it is in the case of GetBatteryAvailability, GetBatteryStatus and GetBatteryChemistry functions, the code returns the actual string value. In the other cases, the functions return the numeric value that corresponds either to a charge percentage or to time (minutes/seconds).

Option Explicit

'-------------------------------------------------------------------------------------------
'This module contains some functions for retrieving information about the laptop's battery.
'The main function is the GetBatteryObject, which retrieves an object containing several
'properties about the laptop's battery. The other functions simply use this object to
'retrieve the appropriate property. The GetBatteryObject function uses WMI to query
'the Win32_Battery class of Windows. More information about this class can be found in:
'https://docs.microsoft.com/en-us/windows/desktop/cimwin32prov/win32-battery

'Written By:    Christos Samaras
'Date:          30/06/2018
'Last Updated:  03/07/2018
'E-mail:        xristos.samaras@gmail.com
'Site:          https://www.myengineeringworld.net
'-------------------------------------------------------------------------------------------

Private Function GetBatteryObject() As Object
    
    '----------------------------------------------------------------------------
    'Returns an object containing several properties about the laptop's battery.
    'The function is private, so as to not be visible from Excel worksheets.
    '----------------------------------------------------------------------------
    
    'Declaring the necessary variables.
    Dim computer    As String
    Dim wmiService  As Object
    Dim colItems    As Object
    Dim item        As Object
    
    On Error Resume Next
    
    'Set the computer.
    computer = "."
    
    'The root\cimv2 namespace is used to access the Win32_Battery class.
    Set wmiService = GetObject("winmgmts:\\" & computer & "\root\cimv2")
    
    'A select query is used to get a collection of battery objects.
    Set colItems = wmiService.ExecQuery("SELECT * FROM Win32_Battery", , 48)
    
    'Note, an alternative here will be to select only the properties you need and not all (the asterisk means all).
    'In that case, the query could be written like this:
    'Set colItems = wmiService.ExecQuery("SELECT Availability, BatteryStatus, Chemistry," + _
                                                "EstimatedChargeRemaining, EstimatedRunTime," + _
                                                "TimeOnBattery, TimeToFullCharge FROM Win32_Battery", , 48)
        
    'Get the first object that is not null.
    For Each item In colItems
        If Not IsNull(item) Then Set GetBatteryObject = item
        Exit Function
    Next
    
    'If no battery object is found, return nothing.
    Set GetBatteryObject = Nothing

    On Error GoTo 0
    
End Function

Public Function GetBatteryAvailability() As String
    
    '-----------------------------------------
    'Returns the availability of the battery.
    '-----------------------------------------
    
    'Declaring the necessary variables.
    Dim batteryObject   As Object
    Dim i               As Integer
            
    On Error Resume Next
    
    'Get the battery object.
    Set batteryObject = GetBatteryObject()
    If Not IsObject(batteryObject) Then
        GetBatteryAvailability = "Battery Object Error"
        Exit Function
    End If
    
    'Check if the Availability property can be retrieved.
    If IsNull(batteryObject.Availability) Then
        GetBatteryAvailability = "Battery Property Error"
        Exit Function
    End If
    
    'Get the numeric value from the property.
    i = CInt(batteryObject.Availability)
    If i < 1 Or i > 21 Then
        GetBatteryAvailability = "Battery Availability Error"
        Exit Function
    End If
    
    'Use the numeric value to return the actual string value.
    GetBatteryAvailability = Array("Other", "Unknown", "Running/Full Power", "Warning", "In Test", "Not Applicable", _
                                   "Power Off", "Off Line", "Off Duty", "Degraded", "Not Installed", "Install Error", _
                                   "Power Save - Unknown", "Power Save - Low Power Mode", "Power Save - Standby", _
                                   "Power Cycle", "Power Save - Warning", "Paused", "Not Ready", "Not Configured", _
                                   "Quiesced")(i - 1)
    
    'Release the battery object.
    Set batteryObject = Nothing
    
    On Error GoTo 0
    
End Function

Public Function GetBatteryStatus() As String
    
    '-----------------------------------
    'Returns the status of the battery.
    '-----------------------------------
    
    'Declaring the necessary variables.
    Dim batteryObject   As Object
    Dim i               As Integer
            
    On Error Resume Next
    
    'Get the battery object.
    Set batteryObject = GetBatteryObject()
    If Not IsObject(batteryObject) Then
        GetBatteryStatus = "Battery Object Error"
        Exit Function
    End If
    
    'Check if the BatteryStatus property can be retrieved.
    If IsNull(batteryObject.BatteryStatus) Then
        GetBatteryStatus = "Battery Property Error"
        Exit Function
    End If
    
    'Get the numeric value from the property.
    i = CInt(batteryObject.BatteryStatus)
    If i < 1 Or i > 11 Then
        GetBatteryStatus = "Battery Status Error"
        Exit Function
    End If
    
    'Use the numeric value to return the actual string value.
    GetBatteryStatus = Array("Discharging", "On A/C", "Fully Charged", "Low", "Critical", "Charging", "Charging High", _
                             "Charging Low", "Charging Critical", "Undefined", "Partially Charged")(i - 1)
    
    'Release the battery object.
    Set batteryObject = Nothing
    
    On Error GoTo 0

End Function

Public Function GetBatteryChemistry() As String
    
    '---------------------------------
    'Returns the battery's chemistry.
    '---------------------------------
    
    'Declaring the necessary variables.
    Dim batteryObject   As Object
    Dim i               As Integer
            
    On Error Resume Next
    
    'Get the battery object.
    Set batteryObject = GetBatteryObject()
    If Not IsObject(batteryObject) Then
        GetBatteryChemistry = "Battery Object Error"
        Exit Function
    End If
    
    'Check if the Chemistry property can be retrieved.
    If IsNull(batteryObject.Chemistry) Then
        GetBatteryChemistry = "Battery Property Error"
        Exit Function
    End If
    
    'Get the numeric value from the property.
    i = CInt(batteryObject.Chemistry)
    If i < 1 Or i > 11 Then
        GetBatteryChemistry = "Battery Chemistry Error"
        Exit Function
    End If
    
    'Use the numeric value to return the actual string value.
    GetBatteryChemistry = Array("Other", "Unknown", "Lead Acid", "Nickel Cadmium", "Nickel Metal Hydride", _
                                "Lithium-ion", "Zinc air", "Lithium Polymer")(i - 1)
    
    'Release the battery object.
    Set batteryObject = Nothing
    
    On Error GoTo 0
    
End Function

Public Function GetEstimatedChargeRemaining() As Integer
    
    '-------------------------------------------------------------
    'Returns the remaining charge of the battery as a percentage.
    'A value of 100 means that the battery is fully charged.
    '-------------------------------------------------------------
    
    'Declaring the necessary variable.
    Dim batteryObject   As Object
            
    On Error Resume Next
    
    'Get the battery object.
    Set batteryObject = GetBatteryObject()
    If Not IsObject(batteryObject) Then
        GetEstimatedChargeRemaining = "Battery Object Error"
        Exit Function
    End If
    
    'Check if the EstimatedChargeRemaining property can be retrieved.
    If IsNull(batteryObject.EstimatedChargeRemaining) Then
        GetEstimatedChargeRemaining = "Battery Property Error"
        Exit Function
    End If
    
    'Get the numeric value from the property.
    GetEstimatedChargeRemaining = CInt(batteryObject.EstimatedChargeRemaining)
    
    'Release the battery object.
    Set batteryObject = Nothing
    
    On Error GoTo 0
    
End Function

Public Function GetEstimatedRunTime() As Long
    
    '------------------------------------------------------------------------------------------------------------
    'Returns the time (in minutes) to battery charge depletion under the present load conditions if the utility
    'power is off, or lost and remains off, or the laptop is disconnected from a power source.
    'A value of 30 means that the battery can continue providing power to your laptop for about 30 minutes.
    '------------------------------------------------------------------------------------------------------------
    
    'Declaring the necessary variable.
    Dim batteryObject   As Object
            
    On Error Resume Next
    
    'Get the battery object.
    Set batteryObject = GetBatteryObject()
    If Not IsObject(batteryObject) Then
        GetEstimatedRunTime = "Battery Object Error"
        Exit Function
    End If
        
    'Check if the EstimatedRunTime property can be retrieved.
    If IsNull(batteryObject.EstimatedRunTime) Then
        GetEstimatedRunTime = "Battery Property Error"
        Exit Function
    End If
    
    'Get the numeric value from the property.
    GetEstimatedRunTime = CLng(batteryObject.EstimatedRunTime)
    
    'Release the battery object.
    Set batteryObject = Nothing
    
    On Error GoTo 0
    
End Function

Public Function GetTimeOnBattery() As Long
        
    '------------------------------------------------------------------------------------------------------------------
    'Returns the elapsed time (in seconds) since the computer system's UPS last switched to battery power or the time
    'since the system or UPS was last restarted, whichever is less. If the battery is "online", 0 (zero) is returned.
    '------------------------------------------------------------------------------------------------------------------
    
    'Declaring the necessary variable.
    Dim batteryObject   As Object
            
    On Error Resume Next
    
    'Get the battery object.
    Set batteryObject = GetBatteryObject()
    If Not IsObject(batteryObject) Then
        GetTimeOnBattery = "Battery Object Error"
        Exit Function
    End If
    
    'Check if the TimeOnBattery property can be retrieved.
    If IsNull(batteryObject.TimeOnBattery) Then
        GetTimeOnBattery = "Battery Property Error"
        Exit Function
    End If
    
    'Get the numeric value from the property.
    GetTimeOnBattery = CLng(batteryObject.TimeOnBattery)
    
    'Release the battery object.
    Set batteryObject = Nothing
    
    On Error GoTo 0
    
End Function

Public Function GetTimeToFullCharge() As Long
    
    '-------------------------------------------------------------------------------------------------------------
    'Returns the remaining time (in minutes) to charge the battery fully at the current charging rate and usage.
    'A value of 45 means that the battery will be fully charged in about 45 minutes.
    '-------------------------------------------------------------------------------------------------------------
    
    'Declaring the necessary variable.
    Dim batteryObject   As Object
            
    On Error Resume Next
    
    'Get the battery object.
    Set batteryObject = GetBatteryObject()
    If Not IsObject(batteryObject) Then
        GetTimeToFullCharge = "Battery Object Error"
        Exit Function
    End If
    
    'Check if the TimeToFullCharge property can be retrieved.
    If IsNull(batteryObject.TimeToFullCharge) Then
        GetTimeToFullCharge = "Battery Property Error"
        Exit Function
    End If
    
    'Get the numeric value from the property.
    GetTimeToFullCharge = CLng(batteryObject.TimeToFullCharge)
    
    'Release the battery object.
    Set batteryObject = Nothing
    
    On Error GoTo 0
    
End Function

The above code is contained in the sample workbook that you will find in the Downloads section that follows. As a bonus tip, you will also find there a "battery chart" that shows the remaining charge of your laptop's battery.



Downloads



Download

The file can be opened with Excel 2007 or newer. Please enable macros before using it.

Sunday, 20 May 2018

Last updated: 20/05/2018, 1 min read

Get External Hyperlinks From A Webpage


Introduction



Some years ago, I published a VBA code that proved to be very popular in blog users: the code and the accompanying workbook could be used for downloading files from the internet. One common request that I get since I published that code, is how to retrieve the hyperlinks from a web page, so as to download the files afterwards.

I decided to help all these blog users by creating a workbook that does exactly what they requested. So, the workbook that you will find in the downloads section can be used for grabbing all the hyperlinks from a given URL. The procedure is quite straightforward: just enter the URL on a specific cell and hit the Get Links button. After a few seconds (depending on your internet speed) you will have all the external hyperlinks from the particular URL. Moreover, apart from the hyperlinks, you will also get the displayed text for each hyperlink. In this way, you can match the hyperlink with its position on the web page and filter out those links that are not relevant.

NOTE: the code ignores internal hyperlinks and anchor tags. In other words, the hyperlinks that are retrieved should all start with "http".



Demonstration video



The short video below demonstrates the usage of the spreadsheet using as an example the URL of this blog. In the particular case, 43 hyperlinks retrieved.




Downloads



Download

The file can be opened with Excel 2007 or newer. Please enable macros before using it. The VBA code was protected using the Unviewable+.



Read also



Excel & VBA: Download Internet Files Automatically

Monday, 30 April 2018

Last updated: 03/05/2018, 2 min read (without the code)

Open A Password-Protected PDF File With VBA


Introduction



In the past, we have seen two ways to open PDF files with VBA: the first one involved the usage of the Adobe Object Model and it could be only used with Adobe Professional. The second one was more generic; it was taking advantage of the Windows API functions and it could be used by both Adobe Reader and Professional. Both ways worked and continue to work just fine. There is a problem, though: what will happen if the PDF file you want to open is password-protected? Is there a way to fill the password in the open dialog and continue opening the file?

The answer is, yes! The suggested solution relies on several Windows APIs since the Adobe Object Model does not provide an option/method for including the password when opening a PDF file. Note: the VBA code that you will see below is NOT a password cracking piece of code! The code implies that you know the password of the file. It just automates the opening procedure, especially if you have to open multiple PDF files.


Spy++ For Opening Locked PDF File


Main idea



The main idea behind the code below can be divided into four steps:
  1. First of all, the code checks if the given path is valid (e.g. the file exists). Then, the ShellExecute API is used to open the file using the associated default program (either Adobe Reader or Adobe Professional).
  2. The FindWindow API function is used to find the pop-up window that prompts the user to fill the password.
  3. By using the FindWindowEx API function, the code searches the subsequent child windows until the text box is reached (using the class RICHEDIT50W).
  4. Finally, the SendMessage and PostMessage API functions are invoked in order to fill the known password and hit the Open button.
Similar to many previous posts, the Spy++ software was used to specify the windows hierarchy when opening the password-protected file. The above image shows the window tree that should be navigated in order to find the text box that will receive the password.



VBA code



Below you will find the OpenLockedPdf macro that does the main work, the FileExists function that is responsible for testing the file existence, as well as the SamplePdfTest macro that performs a sample test. Note that:
  • The OpenLockedPdf macro can be used to open a PDF file that is NOT password-protected. In that case, the code that is right after the line of ShellExecute is ignored.
  • The macro can be used in every Office application, as well as in AutoCAD. It works with both 32 and 64-bit applications.

Option Explicit

'Declaring the necessary API functions for both 64 and 32 bit applications.
#If VBA7 And Win64 Then
    
    'For 64 bit applications.
    'Performs an operation on a specified file.
    Public Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
                                                        (ByVal hwnd As LongPtr, _
                                                        ByVal lpOperation As String, _
                                                        ByVal lpFile As String, _
                                                        ByVal lpParameters As String, _
                                                        ByVal lpDirectory As String, _
                                                        ByVal nShowCmd As Long) As LongPtr
    
    'Retrieves a handle to the top-level window whose class name and window name match the specified strings.
    'This function does not search child windows. This function does not perform a case-sensitive search.
    Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
                                                        (ByVal lpClassName As String, _
                                                        ByVal lpWindowName As String) As LongPtr
            
    'Retrieves a handle to a window whose class name and window name match the specified strings.
    'The function searches child windows, beginning with the one following the specified child window.
    'This function does not perform a case-sensitive search.
    Public Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
                                                        (ByVal hWnd1 As LongPtr, _
                                                        ByVal hWnd2 As LongPtr, _
                                                        ByVal lpClassName As String, _
                                                        ByVal lpWindowName As String) As LongPtr
       
    'Sends the specified message to a window or windows. The SendMessage function calls the window procedure
    'for the specified window and does not parentWindowurn until the window procedure has processed the message.
    Public Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" _
                                                        (ByVal hwnd As LongPtr, _
                                                        ByVal wMsg As Long, _
                                                        ByVal wParam As LongPtr, _
                                                        lParam As Any) As LongPtr
        
    'Places (posts) a message in the message queue associated with the thread that created the specified
    'window and parentWindowurns without waiting for the thread to process the message.
    Public Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" _
                                                        (ByVal hwnd As LongPtr, _
                                                        ByVal wMsg As Long, _
                                                        ByVal wParam As LongPtr, _
                                                        ByVal lParam As LongPtr) As Long
                                                    
                                                                                                                        
#Else

    'For 32 bit applications.
    Public 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 Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
                                                        (ByVal lpClassName As String, _
                                                        ByVal lpWindowName As String) As Long

    Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
                                                        (ByVal hWnd1 As Long, _
                                                        ByVal hWnd2 As Long, _
                                                        ByVal lpClassName As String, _
                                                        ByVal lpWindowName As String) As Long

    Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
                                                        (ByVal hwnd As Long, _
                                                        ByVal wMsg As Long, _
                                                        ByVal wParam As Long, _
                                                        lParam As Any) As Long

    Public Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" _
                                                        (ByVal hwnd As Long, _
                                                        ByVal wMsg As Long, _
                                                        ByVal wParam As Long, _
                                                        ByVal lParam As Long) As Long
                                                        
#End If

'Constants used in API functions.
Public Const SW_HIDE As Long = 0
Public Const SW_SHOWNORMAL As Long = 1
Public Const SW_SHOWMAXIMIZED As Long = 3
Public Const SW_SHOWMINIMIZED As Long = 2
Public Const WM_SETTEXT = &HC
Public Const VK_RETURN = &HD
Public Const WM_KEYDOWN = &H100

Public Sub OpenLockedPdf(pdfPath As String, password As String)
    
    '------------------------------------------------------------------------
    'Opens a password-protected PDF file, given its (known) password.
    'API functions are used to find the pop-up window and fill the password.
    '
    'The subroutine can be used in every Office application, as well as
    'in AutoCAD. It works for both 32 and 64 bit applications.
    
    'The macro also works with PDF files that are NOT password-protected.
    'In that case, the code after the line of ShellExecute is ignored.
    
    'Written By:    Christos Samaras
    'Date:          30/04/2018
    'E-mail:        xristos.samaras@gmail.com
    'Site:          http://www.myengineeringworld.net
    '------------------------------------------------------------------------
           
    'Declaring the necessary variables (different for 32 or 64 bit applications).
    #If VBA7 And Win64 Then
        Dim parentWindow            As LongPtr
        Dim firstChildWindow        As LongPtr
        Dim secondChildFirstWindow  As LongPtr
    #Else
        Dim parentWindow            As Long
        Dim firstChildWindow        As Long
        Dim secondChildFirstWindow  As Long
    #End If
    Dim timeCount                   As Date

    'Check if the PDF file exists.
    If FileExists(pdfPath) = False Then
        MsgBox "The PDF file doesn't exist!", vbCritical, "Error in PDF path"
        Exit Sub
    End If
        
    'The ShellExecute API will try to open the PDF file using the default application that
    'is associated with PDF files (either Adobe Reader or Professional).
    ShellExecute Application.hwnd, "Open", pdfPath, vbNullString, "C:\", SW_SHOWNORMAL
             
    'Note: The code below will be ignored if the PDF file has no protection.
    
    'Find the handle of the pop-up window.
    timeCount = Now()
    Do Until Now() > timeCount + TimeValue("00:00:05")
        parentWindow = 0
        DoEvents
        parentWindow = FindWindow("#32770", "Password")
        If parentWindow <> 0 Then Exit Do
    Loop
    
    If parentWindow <> 0 Then
    
        'Find the handle of the first child window (it is a group box).
        timeCount = Now()
        Do Until Now() > timeCount + TimeValue("00:00:05")
            firstChildWindow = 0
            DoEvents
            firstChildWindow = FindWindowEx(parentWindow, ByVal 0&, "GroupBox", vbNullString)
            If firstChildWindow <> 0 Then Exit Do
        Loop

        'Find the handle of the subsequent child window (it is the text box for filling the password).
        If firstChildWindow <> 0 Then
            timeCount = Now()
            Do Until Now() > timeCount + TimeValue("00:00:05")
                secondChildFirstWindow = 0
                DoEvents
                secondChildFirstWindow = FindWindowEx(firstChildWindow, ByVal 0&, "RICHEDIT50W", vbNullString)
                If secondChildFirstWindow <> 0 Then Exit Do
            Loop
            
            'The handle was found, so...
            If secondChildFirstWindow <> 0 Then
            
                'Fill the password in the text box.
                SendMessage secondChildFirstWindow, WM_SETTEXT, 0&, ByVal password
                
                'Press the OK button (it is the default action, so no need to find the handle of the button).
                PostMessage secondChildFirstWindow, WM_KEYDOWN, VK_RETURN, 0

            End If
        
        End If
        
    End If
   
End Sub

Function FileExists(FilePath As String) As Boolean
   
    '--------------------------------------------------
    'Checks if a file exists (using the Dir function).
    '--------------------------------------------------

    On Error Resume Next
    If Len(FilePath) > 0 Then
        If Not Dir(FilePath, vbDirectory) = vbNullString Then FileExists = True
    End If
    On Error GoTo 0
   
End Function

Sub SamplePdfTest()
    
    'Full path example that can be used in every Office application, as well as with AutoCAD:
    'OpenLockedPdf "C:\Users\Christos\Desktop\Locked File.pdf", "Newsletter"
    
    'Relative path example (in Excel):
    'OpenLockedPdf ThisWorkbook.Path & "\" & "Locked File.pdf", "Newsletter"
    
    'For this example only (with the button):
    OpenLockedPdf ThisWorkbook.Sheets("Open Locked Sample File").Range("C3"), ThisWorkbook.Sheets("Open Locked Sample File").Range("C5")
    
End Sub



Demonstration video



The video that follows demonstrates the result of the "OpenLockedPdf" macro, as well  as gives more information on the usage of Spy++.




Downloads



Download

The zip file contains a sample PDF file that is locked with a password, as well as a sample workbook containing the code presented above that can be used to open that file (the password is included). The workbook can be opened with Excel 2007 or newer. Please enable macros before using it. Finally, there is also a VBA module with the code to attach it in any Office or AutoCAD application you might have.



Read also



VBA Macro To Open A PDF File
Open PDF File With VBA

Wednesday, 21 March 2018

Last updated: 09/08/2018, 1 min read (without the code)

Reverse Geocoding Using VBA & Google API


Introduction



After updating the existing VBA functions that dealt with Google APIs, it is time to introduce a new function that can be used for Reverse Geocoding, a short definition of which, based on Wikipedia, is the following: “Reverse geocoding is the process of back (reverse) coding of a point location (latitude, longitude) to a readable address or place name. This permits the identification of nearby street addresses, places, and/or areal subdivisions such as neighbourhoods, county, state, or country”.

The developed VBA function can be utilized directly from Excel, as long as the user provides a valid pair of latitude and longitude. The GetAddress function sends a request to the Google server and, then, uses its XML response to read the appropriate information (the formatted address in particular). If you are curious how the server response looks like, see the picture below, where the main nodes are highlighted in red boxes. This function does the exact opposite of the GetCoordinates function that was written a few years ago.

Reverse Geocoding Response

Apart from latitude and longitude, the function incorporates an optional third parameter (ResultTypeFilter). This parameter acts as a filter, by reducing/filtering the results returned from the server. In the code comments, you will find the values that are supported.



VBA code



Below you will find the VBA code for the GetAddress function. Bear in mind that the use of the Google Geocoding API is subject to a limit of 40,000 requests per month, so be careful not to exceed this limit. To use this VBA function you will need a valid API key. Check this link that presents a step-by-step guide on how to acquire one for free.

Option Explicit

Function GetAddress(Latitude As Double, Longitude As Double, Optional ResultTypeFilter As String) As String
    
    '-----------------------------------------------------------------------------------------------------------------------
    'This function returns the address of a given latitude, longitude pair using the Google (Reverse) Geocoding API.
    
    'The optional paramter ResultTypeFilter is a filter of one or more address types, separated by a pipe (|).
    'If the parameter contains multiple address types, the API returns all addresses that match any of the types.
    'A note about processing: The result_type parameter does not restrict the search to the specified address type(s).
    'Rather, the result_type acts as a post-search filter: the API fetches all results for the specified latlng,
    'then discards those results that do not match the specified address type(s).
        
    'The following values are supported:
    'street_address: indicates a precise street address.
    'route: indicates a named route (such as "US 101").
    'intersection: indicates a major intersection, usually of two major roads.
    'political: indicates a political entity. Usually, this type indicates a polygon of some civil administration.
    'country: indicates the national political entity, and is typically the highest order type returned by the Geocoder.
    'administrative_area_level_1: indicates a first-order civil entity below the country level. Within the United States,
        'these administrative levels are states. Not all nations exhibit these administrative levels.
        'In most cases, administrative_area_level_1 short names will closely match ISO 3166-2 subdivisions and other
        'widely circulated lists; however this is not guaranteed as our geocoding results are based on a variety of
        'signals and location data.
    'administrative_area_level_2: indicates a second-order civil entity below the country level. Within the United States,
        'these administrative levels are counties. Not all nations exhibit these administrative levels.
    'administrative_area_level_3: indicates a third-order civil entity below the country level.
        'This type indicates a minor civil division. Not all nations exhibit these administrative levels.
    'administrative_area_level_4: indicates a fourth-order civil entity below the country level.
        'This type indicates a minor civil division. Not all nations exhibit these administrative levels.
    'administrative_area_level_5: indicates a fifth-order civil entity below the country level.
        'This type indicates a minor civil division. Not all nations exhibit these administrative levels.
    'colloquial_area" indicates a commonly-used alternative name for the entity.
    'locality: indicates an incorporated city or town political entity.
    'ward: indicates a specific type of Japanese locality, to facilitate distinction between multiple
        'locality components within a Japanese address.
    'sublocality: indicates a first-order civil entity below a locality. For some locations may receive one of the
        'additional types: sublocality_level_1 to sublocality_level_5. Each sublocality level is a civil entity.
        'Larger numbers indicate a smaller geographic area.
    'neighborhood: indicates a named neighborhood
    'premise: indicates a named location, usually a building or collection of buildings with a common name
    'subpremise: indicates a first-order entity below a named location, usually a singular building within
        'a collection of buildings with a common name
    'postal_code: indicates a postal code as used to address postal mail within the country.
    'natural_feature: indicates a prominent natural feature.
    'airport: indicates an airport.
    'park: indicates a named park.
    'point_of_interest: indicates a named point of interest. Typically, these "POI"s are prominent local entities that
        'don't easily fit in another category, such as "Empire State Building" or "Statue of Liberty."
    
    'The function ignores parameters such as language and location_type and returns always the FIRST RESULT.
    
    'NOTE: As Google points out, the use of the Google Geocoding API is subject to a limit of 40,000
    'requests per month, so be careful not to exceed this limit. For more info check:
    'https://cloud.google.com/maps-platform/pricing/sheet
        
    'In order to use this function you must enable the XML, v3.0 library from VBA editor:
    'Go to Tools -> References -> check the Microsoft XML, v3.0.
    
    'Moreover, to use this function you will also need a valid API key.
    'Check the next link that guides you on how to acquire a free API key:
    'https://www.myengineeringworld.net/2018/02/how-to-get-free-google-api-key.html
    
    'Written By:    Christos Samaras
    'Date:          17/03/2018
    'Last Updated:  09/08/2018
    'E-mail:        xristos.samaras@gmail.com
    'Site:          https://www.myengineeringworld.net
    '-----------------------------------------------------------------------------------------------------------------------
    
    'Declaring the necessary variables. Using 30 at the first two variables because it
    'corresponds to the "Microsoft XML, v3.0" library in VBA (msxml3.dll).
    Dim ApiKey          As String
    Dim Request         As New XMLHTTP30
    Dim Results         As New DOMDocument30
    Dim StatusNode      As IXMLDOMNode
    Dim AddressNode     As IXMLDOMNode

    'Set your API key in this variable. Check this link for more info:
    'https://www.myengineeringworld.net/2018/02/how-to-get-free-google-api-key.html
    ApiKey = "Your API Key goes here!"
    
    'Check that an API key has been provided.
    If ApiKey = vbNullString Or ApiKey = "Your API Key goes here!" Then
        GetAddress = "Invalid API Key"
        Exit Function
    End If
    
    'Check the input variables:
    'The valid range of latitude in degrees is -90 and +90 for the Southern and Northern hemisphere respectively.
    If Latitude < -90 Or Latitude > 90 Then
        GetAddress = "Invalid Latitude value"
        Exit Function
    End If

    'Longitude is in the range -180 and +180 specifying coordinates West and East of the Prime Meridian, respectively.
    If Longitude < -180 Or Longitude > 180 Then
        GetAddress = "Invalid Longitude value"
        Exit Function
    End If
      
    'Generic error handling.
    On Error GoTo errorHandler
    
    'Create the request based on Google's (Reverse) Geocoding API. Parameters:
    '- latlng: The latitude and longitude values specifying the location for which you wish to obtain the closest, human-readable address.
    '- key: Your application's API key. This key identifies your application for purposes of quota management.
    'Differentiate the request if a filter is provided.
    If ResultTypeFilter = vbNullString Then
        Request.Open "GET", "https://maps.googleapis.com/maps/api/geocode/xml?" _
                            & "latlng=" & Latitude & "," & Longitude & "&key=" & ApiKey, False
    Else
        Request.Open "GET", "https://maps.googleapis.com/maps/api/geocode/xml?" _
                            & "latlng=" & Latitude & "," & Longitude & "&result_type=" & ResultTypeFilter & "&key=" & ApiKey, False
    End If
    'Send the request to the Google server.
    Request.send
    
    'Read the results from the request.
    Results.LoadXML Request.responseText
    
    'Get the status node value.
    Set StatusNode = Results.SelectSingleNode("//status")
    
    'Based on the status node result, proceed accordingly.
    Select Case UCase(StatusNode.Text)
    
        Case "OK"   'The API request was successful. At least one result was returned.
        
            'Get the formatted address of the first result.
            Set AddressNode = Results.SelectSingleNode("//result/formatted_address")
            
            'Return the address.
            GetAddress = AddressNode.Text
                    
        Case "ZERO_RESULTS"   'The geocode was successful but returned no results.
            GetAddress = "The address probably not exists"
            
        Case "OVER_QUERY_LIMIT" 'The requestor has exceeded the limit of 2500 request/day.
            GetAddress = "Requestor has exceeded the server limit"
            
        Case "REQUEST_DENIED"   'The API did not complete the request.
            GetAddress = "Server denied the request"
            
        Case "INVALID_REQUEST"  'The API request is empty or is malformed.
            GetAddress = "Request was empty or malformed"
        
        Case "UNKNOWN_ERROR"    'Indicates that the request could not be processed due to a server error.
            GetAddress = "Unknown error"
        
        Case Else   'Just in case...
            GetAddress = "Error"
        
    End Select
        
    'Release the objects.
errorHandler:
    Set AddressNode = Nothing
    Set StatusNode = Nothing
    Set Results = Nothing
    Set Request = Nothing
    
End Function

NOTE: In case of multiple results, the function returns the first result, so be careful with your inputs. Tip: use the ResultTypeFilter parameter to reduce the results that are returned. For anyone who is interested to learn how the Google (Reverse) Geocoding API works, he/she can visit the corresponding page.



Downloads



Download

The file can be opened with Excel 2007 or newer. Please enable macros before using it.



Read also



How To Get A Free Google API Key
Geocoding Using VBA & Google API 
Custom Trip Distance Function (VBA & Google Directions API)
Custom Elevation Function (VBA & Google API)