Get Default Mail Client

Are your clients/co-workers work on Mail Clients (Microsoft Outlook, Outlook Express or Lotus Notes)?
Don’t worry, you can know their mail client with this simple code below:

Function CheckDefaultMailClient() As String
    'Reads the value for the default email client from Registry
    'If the key cannot be found, the return value is ""

    Dim objWindowsScript As Object
    Dim strDefaultMailClient As String
    Dim strRegistryKey As String

    strRegistryKey = "HKEY_LOCAL_MACHINE\SOFTWARE\Clients\Mail\"

    On Error Resume Next
    'Access Windows scripting
    Set objWindowsScript = CreateObject("WScript.Shell")
    'Read key from registry
    strDefaultMailClient = objWindowsScript.RegRead(strRegistryKey)

    If strDefaultMailClient = vbNullString Or strDefaultMailClient = "" Then
        CheckDefaultMailClient = ""
    Else
        CheckDefaultMailClient = strDefaultMailClient
    End If
End Function

Advertisements

Get FileType And Executable File Path Of A File

Ever wondered if you needed the FileType and Executable File Path of a particular file? Well, I had to. So, I started to look into my famous, all time (24 X 7) library – internet. And found out that I can use the FileSystemObject and an API declaration to finish my work. So, here it goes.

For FileType, I used FileSystemObject and File object. And, for Executable File Path, I declared an API Function, FindExecutable using shell.dll library.

Here goes the code:

Private Declare Function FindExecutable Lib “shell32.dll” Alias “FindExecutableA” _
    (ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long

Sub Check()
    Dim strExecutableProgramPath As String
    Dim strFilePathAndName As String, strFileType As String
    Dim objFileSystem As Object, objFile As Object
    
    'Create FileSystemObject
    Set objFileSystem = CreateObject(“Scripting.FileSystemObject”)
    strFilePathAndName = Worksheets(“Sheet1”).Range(“B1”).Value
    
    'Create File object and get FileType
    Set objFile = objFileSystem.GetFile(strFilePathAndName)
    strFileType = objFile.Type
    
    strExecutableProgramPath = FindExecutableProgram(strFilePathAndName)
    
    Worksheets(“Sheet1”).Range(“B2”).Value = strFileType
    Worksheets(“Sheet1”).Range(“B3”).Value = strExecutableProgramPath
    
    Set objFile = Nothing
    Set objFileSystem = Nothing
End Sub

Private Function FindExecutableProgram(FilePathAndNameWithExtension As String) As String
    Dim lngReturnValue As Long
    Dim strBuffer As String
    
    strBuffer = Space(260)
    
    'FindExecutable:
    'Retrieve the name and handle of the executable, associated with this file
    'Returns a value greater than 32 if successful.
    'Or a value less than or equal to 32 representing an error.
    'Return Value/Code Description
    '2 SE_ERR_FNF The specified file was not found.
    '3 SE_ERR_PNF The specified path is invalid.
    '5 SE_ERR_ACCESSDENIED The specified file cannot be accessed.
    '8 SE_ERR_OOM The system is out of memory or resources.
    '31 SE_ERR_NOASSOC There is no association for the specified file type with an executable file.
    
    lngReturnValue = FindExecutable(FilePathAndNameWithExtension, vbNullString, strBuffer)
    If lngReturnValue > 32 Then
        FindExecutableProgram = Left$(strBuffer, InStr(strBuffer, Chr$(0)) – 1)
    Else
        FindExecutableProgram = “No association found!”
    End If
End Function

Get Column Letter From Column Number

To get the Letter of a column, there are two ways.

#1 (Simplest way, I think):

Function GetColumnLetter(ColumnNumber As Long) As String
    GetColumnLetter = Split(Columns(ColumnNumber).Address(), “$”)(2)
End Function

#2:

Function GetColumnLetter(ByVal ColumnNumber As Long, _
  Optional ColumnName As String = “”) As String
    If ColumnNumber = 0 Then
        GetColumnLetter = ColumnName
    Else
        ColumnName = Chr(65 + (ColumnNumber – 1) Mod 26) & ColumnName
        ColumnNumber = (ColumnNumber – 1) \ 26
        GetColumnLetter = GetColumnLetter(ColumnNumber, ColumnName)
    End If
End Function

Find The Active Last Column Number

The below code should work in all versions of Excel (if not, please let me know):

Function GetColumnCount(WorksheetName As String, RowNumber As Long) As Long
    With Worksheets(WorksheetName)
        GetColumnCount = .Cells(RowNumber, .Columns.Count).End(xlToLeft).Column
    End With
End Function

Find The Active Last Row Number

The below code should work in all versions of Excel (if not, please let me know):

Function GetRowCount(WorksheetName As String, ColumnNumber As Long) As Long
    With Worksheets(WorksheetName)
        GetRowCount = .Cells(.Rows.Count, ColumnNumber).End(xlUp).Row
    End With
End Function

FileSystemObject

Today, let’s try the FileSystemObject.

What is FileSystemObject?
The FileSystemObject, or FSO, is an often used component to access the file system. For example, you can create files, read the contents of files, determine whether or not a folder or file exists, iterate through the contents of a folder or directory, or any other number of file system-related tasks.

FileSystemObject can be found in Scrrun.dll. In addition to FileSystemOject, Scrrun.dll includes four other objects available for File I/O and other tasks. These objects include the File object, the TextStreamObject object, the Folder object, and the Drive object. We will concentrate on FileSystemObject.

Public Sub CreateFolder()
    'Create a folder using FileSystemObject
    Dim objFileSystemObject As Scripting.FileSystemObject
    Dim FolderPath As String, FolderNameToCreate As String, FullPath As String

    'Get the folder path and folder name to create
    FolderPath = Sheets(“Create”).Range(“B1”).Value
    FolderNameToCreate = Sheets(“Create”).Range(“B2”).Value

    'Create FileSystemObject object
    Set objFileSystemObject = New Scripting.FileSystemObject

    'Check if “\” (backslash) is available at the end of the folder path and add if it’s not there
    If Right(FolderPath, 1) <> “\” Then FolderPath = FolderPath & “\”

    If Not objFileSystemObject.FolderExists(FolderPath) Then
        'If the folder path does not exist
        MsgBox “The folder, ” & FolderPath & ” does not exist.”, _
            vbOKOnly, “Create Folder Using FSO”
        Exit Sub
    End If

    FullPath = FolderPath & FolderNameToCreate

    If Not objFileSystemObject.FolderExists(FullPath) Then
        'If the folder to create does not exist, create the folder
        Call objFileSystemObject.CreateFolder(FullPath)
    Else
        'If the folder to create exists
        MsgBox “The folder, ” & FolderNameToCreate & ” already exists!”, _
            vbOKOnly, “Create Folder Using FSO”
    End If

    Set objFileSystemObject = Nothing
End Sub

Public Sub CopyFolder()
    'Copy a folder using FileSystemObject
    Dim objFileSystemObject As Scripting.FileSystemObject
    Dim SourceFilePath As String, DestinationFilePath As String

    'Get source folder and target folder names
    SourceFilePath = Sheets(“Copy”).Range(“B1”).Value
    DestinationFilePath = Sheets(“Copy”).Range(“B2”).Value

    'Check if “\” (backslash) is available at the end of the folder path and remove if it’s there
    If Right(SourceFilePath, 1) = “\” Then _
        SourceFilePath = Left(SourceFilePath, (Len(SourceFilePath) – 1))

    'Check if “\” (backslash) is available at the end of the folder path and remove if it’s there
    If Right(DestinationFilePath, 1) = “\” Then _
        DestinationFilePath = Left(DestinationFilePath, (Len(DestinationFilePath) – 1))

    'Create FileSystemObject object
    Set objFileSystemObject = New Scripting.FileSystemObject

    If Not objFileSystemObject.FolderExists(SourceFilePath) Then
        'If source folder does not exist
        MsgBox “The folder, ” & SourceFilePath & ” does not exist.”, _
            vbOKOnly, “Copy Folder Using FSO”

        Exit Sub
    End If

    If Not objFileSystemObject.FolderExists(DestinationFilePath) Then
        'If destination folder does not exist
        objFileSystemObject.CopyFolder SourceFilePath, DestinationFilePath
    Else
        'If destination folder exists
        MsgBox “The folder, ” & DestinationFilePath & ” already exists!”, _
            vbOKOnly, “Copy Folder Using FSO”
    End If

    Set objFileSystemObject = Nothing
End Sub

Public Sub MoveFolder()
    'Move a folder using FileSystemObject (moving and renaimg a folder)
    Dim objFileSystemObject As Scripting.FileSystemObject
    Dim SourceFilePath As String, DestinationFilePath As String

    'Get source folder and target folder names
    SourceFilePath = Sheets(“Move”).Range(“B1”).Value
    DestinationFilePath = Sheets(“Move”).Range(“B2”).Value

    'Check if “\” (backslash) is available at the end of the folder path and remove if it’s there
    If Right(SourceFilePath, 1) = “\” Then _
        SourceFilePath = Left(SourceFilePath, (Len(SourceFilePath) – 1))

    'Check if “\” (backslash) is available at the end of the folder path and remove if it’s there
    If Right(DestinationFilePath, 1) = “\” Then _
        DestinationFilePath = Left(DestinationFilePath, (Len(DestinationFilePath) – 1))

    'Create FileSystemObject object
    Set objFileSystemObject = New Scripting.FileSystemObject

    If Not objFileSystemObject.FolderExists(SourceFilePath) Then
        'If source folder does not exist
        MsgBox “The folder, ” & SourceFilePath & ” does not exist.”, _
            vbOKOnly, “Move Folder Using FSO”
        Exit Sub
    End If

    If Not objFileSystemObject.FolderExists(DestinationFilePath) Then
        'If destination folder does not exist, move the folder
        objFileSystemObject.MoveFolder SourceFilePath, DestinationFilePath
    Else
        'If destination folder exists
        MsgBox “The folder, ” & DestinationFilePath & ” already exists!”, _
            vbOKOnly, “Move Folder Using FSO”
    End If

    Set objFileSystemObject = Nothing
End Sub

Public Sub DeleteFolder()
    'Delete a folder using FileSystemObject
    Dim objFileSystemObject As Scripting.FileSystemObject
    Dim RemoveFolderPath As String

    'Get folder path to Delete
    RemoveFolderPath = Sheets(“Delete”).Range(“B1”).Value

    'Check if “\” (backslash) is available at the end of the folder path and remove if it’s there
    If Right(RemoveFolderPath, 1) = “\” Then _
        RemoveFolderPath = Left(RemoveFolderPath, (Len(RemoveFolderPath) – 1))

    'Create FileSystemObject object
    Set objFileSystemObject = New Scripting.FileSystemObject

    If objFileSystemObject.FolderExists(RemoveFolderPath) Then
        'If the folder exists, delete the folder
        objFileSystemObject.DeleteFolder RemoveFolderPath, True
    Else
        'If folder does not exist
        MsgBox “The folder, ” & RemoveFolderPath & ” does not exist.”, _
            vbOKOnly, “Move Folder Using FSO”
    End If

    Set objFileSystemObject = Nothing
End Sub

Sorting Worksheets In Ascending Or Descending Order

Today, I would like to show a code which I created to sort the worksheets in ascending or descending order in the current workbook. I have opted bubble sort to sort the names.

What did I do?

First, I counted the number of worksheets available in the current workbook. Then created an array and saved the worksheets’ names in the array, sorted the names in ascending or descending order (two codes – based on your requirement, you can choose any one) and moved the worksheets according to the sorted order. In the end, show/select the first worksheet.

Here goes the code:

Sub SortWorksheetNamesAscending()
    Dim NoOfSheets As Long, Counter As Long
    Dim Counter1 As Long, Counter2 As Long
    Dim TemporaryVariable As String
    Dim WkShtsNames() As String

    'Count the number of sheets in the workbook
    NoOfSheets = ActiveWorkbook.Worksheets.Count

    'Redefine and assign the names of the worksheets in WkShtsNames array
    ReDim WkShtsNames(1 To NoOfSheets)
    For Counter = 1 To NoOfSheets
        WkShtsNames(Counter) = ActiveWorkbook.Worksheets(Counter).Name
    Next Counter

    'Sort the worksheets' names in ascending order
    For Counter1 = LBound(WkShtsNames) To UBound(WkShtsNames)
        For Counter2 = LBound(WkShtsNames) To UBound(WkShtsNames)
            If WkShtsNames(Counter1) < WkShtsNames(Counter2) Then
                TemporaryVariable = WkShtsNames(Counter1)
                WkShtsNames(Counter1) = WkShtsNames(Counter2)
                WkShtsNames(Counter2) = TemporaryVariable
            End If
        Next Counter2
    Next Counter1

    'Move the worksheets according to the sorted order
    For Counter = 1 To NoOfSheets
        If Counter = 1 Then
            If ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Index <> Counter Then
                ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Move _
                    ActiveWorkbook.Worksheets(1)
            End If
        ElseIf Counter = NoOfSheets Then
            If ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Index <> Counter Then
                ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Move _
                    ActiveWorkbook.Worksheets.Count
            End If
        Else
            ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Move _
                After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets(Counter – 1).Name)
        End If
    Next Counter

    'Select the first worksheet
    ActiveWorkbook.Worksheets(1).Select
End Sub

Sub SortWorksheetNamesDescending()
    Dim NoOfSheets As Long, Counter As Long
    Dim Counter1 As Long, Counter2 As Long
    Dim TemporaryVariable As String
    Dim WkShtsNames() As String

    ‘Count the number of sheets in the workbook
    NoOfSheets = ActiveWorkbook.Worksheets.Count

    ‘Redefine and assign the names of the worksheets in WkShtsNames array
    ReDim WkShtsNames(1 To NoOfSheets)
    For Counter = 1 To NoOfSheets
        WkShtsNames(Counter) = ActiveWorkbook.Worksheets(Counter).Name
    Next Counter

    ‘Sort the worksheets’ names in descending order
    For Counter1 = LBound(WkShtsNames) To UBound(WkShtsNames)
        For Counter2 = LBound(WkShtsNames) To UBound(WkShtsNames)
            If WkShtsNames(Counter1) > WkShtsNames(Counter2) Then
                TemporaryVariable = WkShtsNames(Counter1)
                WkShtsNames(Counter1) = WkShtsNames(Counter2)
                WkShtsNames(Counter2) = TemporaryVariable
            End If
        Next Counter2
    Next Counter1

    ‘Move the worksheets according to the sorted order
    For Counter = 1 To NoOfSheets
        If Counter = 1 Then
            If ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Index <> Counter Then
                ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Move _
                    ActiveWorkbook.Worksheets(1)
            End If
        ElseIf Counter = NoOfSheets Then
            If ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Index <> Counter Then
                ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Move _
                    ActiveWorkbook.Worksheets.Count
            End If
        Else
            ActiveWorkbook.Worksheets(WkShtsNames(Counter)).Move _
                After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets(Counter – 1).Name)
        End If
    Next Counter

    ‘Select the first worksheet
    ActiveWorkbook.Worksheets(1).Select
End Sub