Print Debug Messages

It’s really helpful when developing macros in VBA to get some sort of feedback from the code as to what is going on behind the scenes. Doing this has helped me get rid of superfluous reiterations.

1. Show the Immediate window

immediate_window1

2. Add descriptive messages to the code

add message for immediate window

3. See the debug messages as they are encountered

read immediate window

Copy Column Widths

I ran into this code when trying to copy some rows from one sheet to another in Excel through VBA. The widths would always display at the destination spreadsheet’s default column width. This code helps, all you need to pass it is the source and target ranges as parameters.

Code

Private Sub copyColumnWidths(TargetRange As Range, SourceRange As Range)
Dim c As Long
    With SourceRange
        For c = 1 To .Columns.Count
            TargetRange.Columns(c).ColumnWidth = .Columns(c).ColumnWidth
        Next c
    End With
End Sub

Example call

copyColumnWidths Sheets("MySheet").Range("A1:AA500"), Sheets("YourSheet").Range("A1:AA500")

Read Word Document Using NetOffice 1.60

I needed to look through a Word document for an application running the .NET 2.0 framework. Here is how I did it using NetOffice 1.60 which can be downloaded via NuGet in Visual Studio.

Imports Word = NetOffice.WordApi
Imports NetOffice.WordApi.Enums

Module Module1

    Sub Main()
        readWordDoc()
    End Sub

    Private Sub readWordDoc()

        ' start word and turn off msg boxes
        Dim wordApplication As New Word.Application
        wordApplication.DisplayAlerts = WdAlertLevel.wdAlertsNone

        ' open document as read only
        Dim myDocument As Word.Document
        myDocument = wordApplication.Documents.Open(System.IO.Path.GetFullPath("MyDoc.docx"), False, True)

        ' get document's content
        Dim content As String
        content = myDocument.Content.Text

        ' close doc
        wordApplication.Quit()
        wordApplication.Dispose()

        ' output content 
        Console.WriteLine(content)
        Console.ReadKey()

    End Sub

End Module

How to Create a PDF

Useful function that creates a PDF in VBA.

Usage:
Creating a PDF from the active worksheet.

    Dim myFile As String
    'Save PDF being generated to Temp location
    myFile  = IIf(Environ$("tmp") <> "", Environ$("tmp"), Environ$("temp")) & "myPDF.pdf"
    fileToSend = Create_PDF(ActiveWorkbook.ActiveSheet, myFile, True, False)

The code:

Function Create_PDF(Myvar As Object, FixedFilePathName As String, _
                 OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
    Dim FileFormatstr As String
    Dim Fname As Variant

    'Test to see if the Microsoft Create/Send add-in is installed.
    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
         & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

        If FixedFilePathName = "" Then
            'Open the GetSaveAsFilename dialog to enter a file name for the PDF file.
            FileFormatstr = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
                  Title:="Create PDF")

            'If you cancel this dialog, exit the function.
            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If

        'If OverwriteIfFileExist = False then test to see if the PDF
        'already exists in the folder and exit the function if it does.
        If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If

        'Now export the PDF file.
        On Error Resume Next
        Myvar.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                Filename:=Fname, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=OpenPDFAfterPublish
        On Error GoTo 0

        'If the export is successful, return the file name.
        If Dir(Fname) <> "" Then Create_PDF = Fname
    End If
End Function

Sending Email Through SMTP (Using CDOSYS)

Very handy function for sending emails through SMTP using VBA.

Sub Mail_SMTP(StrAttachment As String, StrTo As String, StrSubject As String, StrBody As String, Send As Boolean)
    
    On Error GoTo ErrHandler
    
    Dim smtp_username As String
    Dim smtp_password As String
       
    smtp_username = ""
    smtp_password = ""
    
    Dim iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant
    
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

    iConf.Load -1
    Set Flds = iConf.Fields
    With Flds
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.mycompany.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = smtp_username
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = smtp_password
        .Update
    End With

    With iMsg
        Set .Configuration = iConf
        .To = StrTo
        .CC = ""
        .BCC = ""
        .From = getUsername() & "@mycompany.com"
        .Subject = StrSubject
        .TextBody = StrBody
        .AddAttachment StrAttachment
        If Send = True Then
            iMsg.Send
        Else
            iMsg.Display
        End If
    End With
    
    If Err.Number = 0 Then
        MsgBox "Email sent to: " & StrTo, vbInformation, "Email"
    End If
    
ErrExit:
    Exit Sub

ErrHandler:
    MsgBox "Unable to send email. Please make sure you are connected to the internet."
    Resume ErrExit
    
End Sub

Sending an Email Through Outlook

This handy function sends an email through Excel using VBA.

Sub Mail_Outlook(StrAttachment As String, StrTo As String, StrSubject As String, StrBody As String, Send As Boolean)
    
    Dim OutApp As Object
    Dim OutMail As Object
    
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error GoTo ErrHandler
    
    With OutMail
        .To = StrTo
        .CC = ""
        .BCC = ""
        .Subject = StrSubject
        .Body = StrBody
        .Attachments.Add StrAttachment
        If Send = True Then
            .Send
        Else
            .Display
        End If
    End With
    If Err.Number = 0 Then
        MsgBox "Email sent to: " & StrTo, vbInformation, "Email"
    End If

ErrExit:
    Set OutMail = Nothing
    Set OutApp = Nothing
    Exit Sub
    
ErrHandler:
    MsgBox "Description     : " & Err.Description & vbNewLine & _
           "Error Number    : " & Err.Number, vbOKOnly, "Error"
           
    Resume ErrExit
    
End Sub

Setting Tab Order In Excel

I found a couple of different ways to do this but by far this was the less obtrusive one.

Please note that the left section of the formula checks your current location and the right section dictates your next location.

Private Sub Worksheet_Change(ByVal Target As Range)
    'jump B2->B3->B4->B5->B6->B7
    If Target.Cells.Address = "$B$1" Then Range("B2").Select
    If Target.Cells.Address = "$B$2" Then Range("B3").Select
    If Target.Cells.Address = "$B$3" Then Range("B4").Select
    If Target.Cells.Address = "$B$4" Then Range("B5").Select
    If Target.Cells.Address = "$B$5" Then Range("B6").Select
    If Target.Cells.Address = "$B$6" Then Range("B7").Select
End Sub

Executing a DB2 Stored Procedure from Excel with Parameters

Recently I had to help someone by creating a small piece of VBA code that would fetch rows returned by an ISeries stored procedure. The stored procedure however required two parameters to be set; a from date and a to date. Since this took some time to research I thought I’d post a simplified version on here for myself as well as anyone who needed the reference.

Note: It is highly recommended that you use parameterized queries and not simply a concatenation of values. https://support.microsoft.com/en-us/kb/181734

Code Comment

The following code gets an user input start date (in YYYYMMDD format) from cell B1 and an end date from cell B2. It then places those dates into the stored procedure as parameters. Any resulting rows (with the exception of headers) are displayed starting from cell A6.

An important thing to note here is the use of

QUERYTIMEOUT=0

in the connection string. Using this keeps your procedure call from timing out.

Additionally note how instead of using a loop, rows returned are simply placed from the recordset to cells A6+ using

Range("A6").CopyFromRecordset Rs

The Code

Sub UpdateQuery()
    
    If IsNumeric(Range("B1").Value) Then
        intStart = Range("B1").Value
    Else
        Exit Sub
    End If
    
    If IsNumeric(Range("B2").Value) Then
        intEnd = Range("B2").Value
    Else
        Exit Sub
    End If
    
    Dim ConnectionString As String
    ConnectionString = "Driver=iSeries Access ODBC Driver;System=ISERIES.COMPANY.COM; QUERYTIMEOUT=0;UID=Username;pwd=Password;"
    
    Dim Cn
    Set Cn = CreateObject("ADODB.Connection")
    Cn.ConnectionTimeout = 0
    Cn.Open ConnectionString
    Set Geti5Connection = Cn
    
    Dim Cm
    Set Cm = CreateObject("ADODB.Command")
    Set Cm.ActiveConnection = Geti5Connection
    Cm.CommandText = "call mylib.myproc(" & intStart & "," & intEnd & ")"
    Set Geti5Command = Cm
    Set Rs = Cm.Execute
    
    Range("A6").CopyFromRecordset Rs
    Set Cm = Nothing

End Sub

Combining CSV Files Programmatically

A while ago I needed to import a bunch of comma-delimited files into the Excel file I working on at work. This was a tedious process and I thought Id speed it up for next time. So sifting through the web and visiting a bunch of different macro websites I piece together this code. It imports all the .csv files within the directory you specify into an Excel file. The code has a few rough edges but I thought Id share before I forgot about it.

Sub ImportCSVs()

 Dim fso     As Object
 Dim fldr    As Object
 Dim fil     As Object
 Dim wbResults As Workbook

 Range("A2").Select

 strFldrPath = ActiveCell.FormulaR1C1 'cell with file path, edit this as needed

 Set fso = CreateObject("scripting.filesystemobject")

 Set fldr = fso.GetFolder(strFldrPath)

 For Each fil In fldr.Files

     Set wbResults = Workbooks.Open(Filename:=fil.Path, UpdateLinks:=0)

     Range("A1:Z600").Copy

     ThisWorkbook.Activate

     Sheets.Add After:=Sheets(Sheets.Count)

     LastSheet = Sheets.Count

     Sheets(LastSheet).Name = fil.Name

     Sheets(LastSheet).Activate

     Range("A1").Select

     ActiveSheet.Paste

     Application.CutCopyMode = False

     wbResults.Close SaveChanges:=False

 Next fil

End Sub