Excel – UserForms with Database Access, Called from VBS

7 02 2010

February 7, 2010

This example shows how to use VBS to call built-in Excel functions, as well as custom developed Excel functions from a VBS file.  Additionally, the VBS code is able to take advantage of an Excel userform that connects to the Oracle database. 

We will start by creating a couple of tables – ideally, we would have more of the application logic and information in each of the database tables, but in this example most of the logic is in Excel.

CREATE TABLE CABINET_BUILDER_WOOD (
  WOOD_TYPE VARCHAR2(30),
  PRIMARY KEY (WOOD_TYPE));

INSERT INTO CABINET_BUILDER_WOOD VALUES ('Birch');
INSERT INTO CABINET_BUILDER_WOOD VALUES ('Cedar');
INSERT INTO CABINET_BUILDER_WOOD VALUES ('Cherry');
INSERT INTO CABINET_BUILDER_WOOD VALUES ('Douglas Fir');
INSERT INTO CABINET_BUILDER_WOOD VALUES ('Ebony');
INSERT INTO CABINET_BUILDER_WOOD VALUES ('Maple');
INSERT INTO CABINET_BUILDER_WOOD VALUES ('Pine');
INSERT INTO CABINET_BUILDER_WOOD VALUES ('Poplar');
INSERT INTO CABINET_BUILDER_WOOD VALUES ('Red Oak');
INSERT INTO CABINET_BUILDER_WOOD VALUES ('Redwood');
INSERT INTO CABINET_BUILDER_WOOD VALUES ('Spruce');
INSERT INTO CABINET_BUILDER_WOOD VALUES ('White Oak');

COMMIT;

CREATE TABLE CABINET_BUILDER_CAB_TYPE (
  CABINET_TYPE VARCHAR2(40),
  PRIMARY KEY (CABINET_TYPE));

INSERT INTO CABINET_BUILDER_CAB_TYPE VALUES ('Base Cabinet Full Depth');
INSERT INTO CABINET_BUILDER_CAB_TYPE VALUES ('Base Cabinet Half Depth');
INSERT INTO CABINET_BUILDER_CAB_TYPE VALUES ('Full Height Base Cabinet');
INSERT INTO CABINET_BUILDER_CAB_TYPE VALUES ('Upper Cabinet');
INSERT INTO CABINET_BUILDER_CAB_TYPE VALUES ('Upper Cabinet Narrow');

COMMIT;

Next, we will start preparing the Excel workbook.  Create a new Excel workbook and save it as C:\ExcelMacroFunctionDemo.xls.  Next, right-click the first worksheet in the workbook and select View Code.  From the Tools menu, select References.  Add a reference to a recent release of the Microsoft ActiveX Data Objects Library, and Microsoft Windows Common Controls 6.0 (hopefully, that version is available on your computer).

From the Tools menu, select Additional Controls.  Place a check next to one of the Microsoft TreeView Controls and then click the OK button.

Next, from the Insert menu, select Module – this is where we will need to add the code so that it may be accessed by the VBS script.  Module1 should appear in the tree structure at the left (officially called the Project Explorer).  Add the following code into the Module1 module (this example is adapted from one that I showed in a presentation to an ERP user’s group, so the contents of some of the functions may seem to be a bit odd):

Option Explicit

'Constants for registry access
Private Const ERROR_SUCCESS = 0&
Private Const SYNCHRONIZE = &H100000
Private Const READ_CONTROL = &H20000
Private Const STANDARD_RIGHTS_ALL = &H1F0000
Private Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Private Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Private Const KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE))
Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))

'For FindWindow
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDNEXT = 2
Private Const SW_SHOW = 5
Private Const SW_RESTORE = 9

'Type declaration for Zebra label printing
Public Type DOC_INFO_1
    pDocName As String
    pOutputFile As String
    pDatatype As String
End Type

'Registry API functions
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long         ' Note that if you declare the lpData parameter as String, you must pass it By Value.

'INI API functions
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

'Zebra Printing API functions
Public Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Public Declare Function EndDocPrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Public Declare Function EndPagePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Public Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, ByVal pDefault As Long) As Long
Public Declare Function StartDocPrinter Lib "winspool.drv" Alias "StartDocPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, pDocInfo As DOC_INFO_1) As Long
Public Declare Function StartPagePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Public Declare Function WritePrinter Lib "winspool.drv" (ByVal hPrinter As Long, pBuf As Any, ByVal cdBuf As Long, pcWritten As Long) As Long

'For Find Window and bring to top
Private Declare Function AttachThreadInput Lib "user32" (ByVal idAttach As Long, ByVal idAttachTo As Long, ByVal fAttach As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private Declare Function IsIconic Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long

'Used by the ShowWindowAfterDelay sub
Dim strFindWindowTitle As String
Dim intFindExitExcel As String

Public Function CalculateCombinations(lngNumberElements As Long, lngNumberPositions) As Double
    'Calculate the number of possible arrangements where the order does not matter of the number of elements into the number of positions
    CalculateCombinations = Application.WorksheetFunction.Combin(lngNumberElements, lngNumberPositions)
End Function

Public Function CalculateInterestPayment(dblInterestRate As Single, lngPaymentsPerYear As Long, lngNumPayments As Long, sglCurrentValue As Single) As Single
    'Calculates the interest payments on a given principal
    CalculateInterestPayment = Abs(Application.WorksheetFunction.Pmt(dblInterestRate / lngPaymentsPerYear, lngNumPayments, sglCurrentValue))
End Function

Public Function CalculatePermutations(lngNumberElements As Long, lngNumberPositions) As Double
    'Calculate the number of possible arrangements where the order matters of the number of elements into the number of positions
    CalculatePermutations = Application.WorksheetFunction.Permut(lngNumberElements, lngNumberPositions)
End Function

Public Function EnvironmentVariable(strIn As String) As String
    'Returns the environment variable set on the computer
        'EnvironmentVariable("windir")       'Windows folder
        'EnvironmentVariable("temp")         'Temp folder
        'EnvironmentVariable("username")     'Username
        'EnvironmentVariable("computername") 'Computer name
    EnvironmentVariable = Environ(strIn)
End Function

Private Function ForceForegroundWindow(ByVal hWnd As Long) As Long
    Dim lngThreadID1 As Long
    Dim lngThreadID2 As Long
    Dim lngResult As Long

    If hWnd = GetForegroundWindow() Then
        ForceForegroundWindow = True
    Else
        lngThreadID1 = GetWindowThreadProcessId(GetForegroundWindow, ByVal 0&)
        lngThreadID2 = GetWindowThreadProcessId(hWnd, ByVal 0&)

        If lngThreadID1 <> lngThreadID2 Then
            Call AttachThreadInput(lngThreadID1, lngThreadID2, True)
            lngResult = SetForegroundWindow(hWnd)
            Call AttachThreadInput(lngThreadID1, lngThreadID2, False)
        Else
            lngResult = SetForegroundWindow(hWnd)
        End If

        If IsIconic(hWnd) Then
            Call ShowWindow(hWnd, SW_RESTORE)
        Else
            Call ShowWindow(hWnd, SW_SHOW)
        End If

        ForceForegroundWindow = lngResult
    End If
End Function

Public Function RegistryGetEntry(strSubKeys As String, strValName As String) As String
    'Reads a string value from the HKEY_CURRENT_USER section of the registry
    Const lngType = 1&
    Const lngKey = &H80000001 'HKEY_CURRENT_USER

    Dim lngResult As Long
    Dim lngHandle As Long
    Dim lngcbData As Long
    Dim strRet As String

    On Error Resume Next

    lngResult = RegOpenKeyEx(lngKey, strSubKeys, 0&, KEY_READ, lngHandle)

    If lngResult <> ERROR_SUCCESS Then
        RegistryGetEntry = "!!!KEY DOES NOT EXIST" & vbTab & Format(lngResult)
        Exit Function
    End If

    strRet = String(300, Chr(0))
    lngcbData = Len(strRet)
    lngResult = RegQueryValueEx(lngHandle, strValName, 0&, lngType, ByVal strRet, lngcbData)

    'See if the value to be returned is longer than the number of character positions in the passed in string
    If lngcbData > 300 Then
        'String not long enough, try again
        strRet = String(lngcbData, Chr(0))
        lngResult = RegQueryValueEx(lngHandle, strValName, 0&, lngType, ByVal strRet, lngcbData)
    End If

    If lngResult <> ERROR_SUCCESS Then
        RegistryGetEntry = "!!!VALUE DOES NOT EXIST" & vbTab & Format(lngResult)
    Else
        RegistryGetEntry = Left(strRet, lngcbData - 1)
    End If

    lngResult = RegCloseKey(lngHandle)
End Function

Public Function RegistrySetEntry(strSubKeys As String, strValName As String, strValue As String) As Long
    Const lngType = 1&
    Const lngKey = &H80000001 'HKEY_CURRENT_USER

    Dim lngResult As Long
    Dim lngHandle As Long
    Dim lngcbData As Long
    Dim strRet As String
    Dim strNewKey As String

    On Error Resume Next

    lngResult = RegCreateKey(lngKey, strSubKeys, lngHandle)

    lngResult = RegSetValueEx(lngHandle, strValName, 0&, lngType, ByVal strValue, Len(strValue))

    If lngResult <> ERROR_SUCCESS Then
        RegistrySetEntry = False
    Else
        RegistrySetEntry = True
    End If

    lngResult = RegCloseKey(lngHandle)
End Function

Public Function ReverseString(strIn As Variant) As Variant
    'Reverses a string value using a simple VBA macro
    Dim i As Integer
    Dim strTemp As String

    For i = Len(strIn) To 1 Step -1
        strTemp = strTemp & Mid(strIn, i, 1)
    Next i

    ReverseString = strTemp
End Function

Public Function RoundNumber(dblIn As Double, intDigits As Integer, intPrintCommas As Integer) As String
    'Switch the value of the variable so that TRUE becomes FALSE and FALSE becomes TRUE
    intPrintCommas = Not intPrintCommas
    'Round the number to the specified number of decimal places
    RoundNumber = Application.WorksheetFunction.Fixed(dblIn, intDigits, intPrintCommas)
End Function

Public Function ShowCabinetBuilder(sglMarkup As Single) As Variant
    Dim i As Integer
    Dim intBOMNodes As Integer
    Dim intBOMCount As Integer
    Dim strMaterialList As String

    frmCabinetBuilder.sglPriceMarkup = sglMarkup
    frmCabinetBuilder.Show

    intBOMNodes = frmCabinetBuilder.tvBillOfMaterial.Nodes.Count
    'Set the initial size of the array to be returned to the number of items in the treeview

    intBOMCount = 0
    If (frmCabinetBuilder.intFormCancelled = False) And (intBOMNodes > 0) Then
        For i = 1 To intBOMNodes
            'Do not return the category headings
            If frmCabinetBuilder.tvBillOfMaterial.Nodes(i).Children = 0 Then
                intBOMCount = intBOMCount + 1
                strMaterialList = strMaterialList & frmCabinetBuilder.tvBillOfMaterial.Nodes(i).Text & vbTab
            End If
        Next i
    Else

    End If

    If strMaterialList <> "" Then
        strMaterialList = Left(strMaterialList, Len(strMaterialList) - 1)
    End If

    ShowCabinetBuilder = strMaterialList

    'Remove the form from memory
    Unload frmCabinetBuilder
End Function

Public Sub ShowWindowWithDelay(strWindowTitle As String, Optional intDelaySeconds As Integer = 1, Optional intExitExcel As Integer = False)
    'Used to display a window that is opened within a Visual macro - usually behind the Visual module

    DoEvents
    'Set a couple module level variables that will be used in the ShowWindowAfterDelay sub
    strFindWindowTitle = strWindowTitle
    intFindExitExcel = intExitExcel

    'After the specified number of seconds locate and show the window
    Application.OnTime DateAdd("s", intDelaySeconds, Now), "ShowWindowAfterDelay"
End Sub

Private Sub ShowWindowAfterDelay()
    Dim intLength As Integer 'Length of the window text length
    Dim strListItem As String 'Name of running programs
    Dim lngCurrWnd As Long 'Current window handle
    Dim lngResult As Long 'Return value from the API calls
    Dim intFlag As Integer

    On Error Resume Next

    lngCurrWnd = GetWindow(Application.hWnd, GW_HWNDFIRST)

    'Loop through all of the top-level windows to find the one of interest
    Do While lngCurrWnd <> 0
        intLength = GetWindowTextLength(lngCurrWnd)
        strListItem = Space$(intLength + 1)
        intLength = GetWindowText(lngCurrWnd, strListItem, intLength + 1)
        If intLength > 0 Then
            If InStr(UCase(strListItem), UCase(strFindWindowTitle)) > 0 Then
                lngResult = ForceForegroundWindow(lngCurrWnd)
                DoEvents

                intFlag = True
                Exit Do
            End If
        End If

        lngCurrWnd = GetWindow(lngCurrWnd, GW_HWNDNEXT)

        DoEvents
    Loop

    strFindWindowTitle = ""

    If intFindExitExcel = True Then
        ActiveWorkbook.Saved = True
        Application.Quit
    End If
End Sub

Public Function ToHexadecimal(dblIn As Double) As String
    'Will not work in Excel 2003
    'Changes the number passed in to hexadecimal using a built-in function, could use VB's HEX function
    ToHexadecimal = Application.WorksheetFunction.Dec2Hex(dblIn)
End Function

Public Function ToRoman(dblIn As Double) As String
    'Changes the number passed in to Roman numerals using a built-in function
    ToRoman = Application.WorksheetFunction.Roman(dblIn, 0)
End Function

Public Function VisualINIGet(strSection As String, strName As String, Optional strINIFile As String = "Visual.ini") As String
    Dim lngResult As Long
    Dim lngRetSize As Long
    Dim strLocalVisualDirectory As String
    Dim strFilename As String
    Dim strRet As String

    strLocalVisualDirectory = RegistryGetEntry("Software\Infor Global Solutions\VISUAL Manufacturing\Configuration", "Local Directory")

    If Left(strLocalVisualDirectory, 3) = "!!!" Then
        'Registry access failed, try again with Lilly Software
        strLocalVisualDirectory = RegistryGetEntry("Software\Lilly Software\VISUAL Manufacturing\Configuration", "Local Directory")
    End If

    If (Left(strLocalVisualDirectory, 3) <> "!!!") And (strLocalVisualDirectory <> "") Then
        'Make certain that the path end in a \
        If Right(strLocalVisualDirectory, 1) <> "\" Then
            strLocalVisualDirectory = strLocalVisualDirectory & "\"
        End If

        'Make certain that the ini file ends with .INI
        If Len(strINIFile) > 4 Then
            If Right(UCase(strINIFile), 4) <> ".INI" Then
                strINIFile = strINIFile & ".ini"
            End If
        Else
            strINIFile = strINIFile & ".ini"
        End If

        strFilename = strLocalVisualDirectory & strINIFile

        lngRetSize = 255
        strRet = String(lngRetSize, Chr(0))
        lngResult = GetPrivateProfileString(strSection, strName, "", strRet, lngRetSize, strFilename)

        If lngResult <> 0 Then
            VisualINIGet = Left(strRet, InStr(strRet, Chr(0)) - 1)
        Else
            VisualINIGet = "!!!VALUE DOES NOT EXIST"
        End If
    Else
        'Registry access failed
        VisualINIGet = "!!!LOCATION OF VISUAL.INI NOT KNOWN"
    End If
End Function

Public Function VisualINISet(strSection As String, strName As String, strValue As String, Optional strINIFile As String = "Visual.ini") As Long
    Dim lngResult As Long
    Dim lngRetSize As Long
    Dim strLocalVisualDirectory As String
    Dim strFilename As String
    Dim strRet As String

    strLocalVisualDirectory = RegistryGetEntry("Software\Infor Global Solutions\VISUAL Manufacturing\Configuration", "Local Directory")

    If Left(strLocalVisualDirectory, 3) = "!!!" Then
        'Registry access failed, try again with Lilly Software
        strLocalVisualDirectory = RegistryGetEntry("Software\Lilly Software\VISUAL Manufacturing\Configuration", "Local Directory")
    End If

    If (Left(strLocalVisualDirectory, 3) <> "!!!") And (strLocalVisualDirectory <> "") Then
        'Make certain that the path end in a \
        If Right(strLocalVisualDirectory, 1) <> "\" Then
            strLocalVisualDirectory = strLocalVisualDirectory & "\"
        End If

        'Make certain that the ini file ends with .INI
        If Len(strINIFile) > 4 Then
            If Right(UCase(strINIFile), 4) <> ".INI" Then
                strINIFile = strINIFile & ".ini"
            End If
        Else
            strINIFile = strINIFile & ".ini"
        End If

        strFilename = strLocalVisualDirectory & strINIFile
        lngResult = WritePrivateProfileString(strSection, strName, strValue, strFilename)

        If lngResult <> 0 Then
            VisualINISet = True
        Else
            VisualINISet = False
        End If
    Else
        VisualINISet = False
    End If
End Function

Public Sub ZebraPrintLabel(strPrinter As Variant, strRawText As Variant)
    'Variables for handling printing
    Dim i As Integer
    Dim lngPrinterHandle As Long
    Dim lngResult As Long
    Dim lngWritten As Long
    Dim lngPrinterDocHandle As Long
    Dim bytRawText() As Byte
    Dim MyDocInfo As DOC_INFO_1

    On Error Resume Next

    'In VB6 to see the list of printer device names, enter the following into the Debug window
    'For i = 0 to Printers.Count - 1:Debug.Print Printers(i).DeviceName:Next

    'strPrinter = "\\MYCOMP\ZEBRA"

    'Sample label
    'strRawText = "~SD25^XA" 'Set Darkness, Label start
    'strRawText = strRawText & "^SZ2" 'Enable ZPL2
    'strRawText = strRawText & "^JZ" 'Reprint on error
    'strRawText = strRawText & "^PR8,8,8" 'Print speed 8" per second, 8" per sec slew, 8" per sec backfeed
    'strRawText = strRawText & "^LH10,26" 'Label home position in pixels
    'strRawText = strRawText & "^FO2,14^A0R,20,20^FDMy Company^FS" 'rotated text in font A
    'strRawText = strRawText & "^FO2,480^A0R,20,20^FDSomewhere^FS"
    'strRawText = strRawText & "^FO180,135^B3R,,105,N^FD" & "ABC111" & "^FS"  'Font 3 of 9 barcode
    'strRawText = strRawText & "^FO180,0^GB0,760,3^FS"  'Vertical Line 3 pixels wide
    'strRawText = strRawText & "^FO335,0^GB0,1218,3^FS"  'Vertical Line 3 pixels wide
    'strRawText = strRawText & "^FO550,0^GB0,1218,3^FS"  'Vertical Line 3 pixels wide
    'strRawText = strRawText & "^FO260,760^GB0,452,3^FS"  'Vertical Line 3 pixels wide
    'strRawText = strRawText & "^FO0,760^GB335,0,3^FS"  'Horizontal Line 3 pixels wide
    'strRawText = strRawText & "^XZ"  'End of label indicator

    'Convert the variant data types to strings
    strPrinter = CStr(strPrinter)
    strRawText = CStr(strRawText)

    'Terminate the string with a CRLF combination (may not be needed)
    If Right(strRawText, 2) <> vbCrLf Then
        strRawText = strRawText & vbCrLf
    End If

    'Convert the strRawText string to a byte stream
    ReDim bytRawText(1 To Len(strRawText))
    For i = 1 To Len(strRawText)
        bytRawText(i) = Asc(Mid(strRawText, i, 1))
    Next i

    'Create a connection to the printer, returns a handle to the printer
    lngResult = OpenPrinter(strPrinter, lngPrinterHandle, 0)

    If lngPrinterHandle = 0 Then
        MsgBox "Could Not Open Printer"
        Exit Sub
    End If

    'Fill in the document header structure
    MyDocInfo.pDocName = "Zebra Label from Excel"
    MyDocInfo.pOutputFile = vbNullString
    MyDocInfo.pDatatype = "RAW"
    lngPrinterDocHandle = StartDocPrinter(lngPrinterHandle, 1, MyDocInfo)

    If lngPrinterDocHandle = 0 Then
        MsgBox "Could Not Start the Document"
        lngResult = ClosePrinter(lngPrinterHandle)
        Exit Sub
    End If

    'Prepare to start the first page
    Call StartPagePrinter(lngPrinterHandle)

    'Write out the contents of the first page
    lngResult = WritePrinter(lngPrinterHandle, bytRawText(1), Len(strRawText), lngWritten)
    If lngResult = 0 Then
        MsgBox "Could Not Write to the Page"
        lngResult = ClosePrinter(lngPrinterHandle)
        Exit Sub
    End If

    'End the first page
    lngResult = EndPagePrinter(lngPrinterHandle)

    'End the document
    lngResult = EndDocPrinter(lngPrinterHandle)

    'Close the connection to the printet
    lngResult = ClosePrinter(lngPrinterHandle)
End Sub

OK, now that the easy part is done, we need to Create the UserForm that will be accessed from the VBS script.  From the Insert menu, select UserForm.  Change the name of the form to frmCabinetBuilder.  Draw a Treeview type control on the userform (the treeview is hilighted in the below screen capture) and name the treeview as tvBillOfMaterial.  Draw two ListBox controls on the userform and name them lstWoodType and lstCabinetType (shown below near the upper left of the userform).  Create three CommandButton contols and name them cmdCreateSalesOrder, cmdCreateWorkOrder, and cmdExit (shown near the bottom of the userform).  Create two TextBox controls and name them txtManufactureCost and txtSalesPrice (shown near the top right of the userform).  Create Label controls on the userform above each of the other controls, and set their Caption property to the text that should appear inside the label control (Wood Type, Cabinet Type, etc.).

Next, we need to add code to the userform so that the controls know what to do.  Double-click the background of the userform, delete any code shown, and add the following code:

Option Explicit 'Forces all variables to be declared

Public intFormCancelled As Integer
Public sglPriceMarkup As Single

Dim dbDatabase As New ADODB.Connection
Dim strDatabase As String
Dim strUserName As String
Dim strPassword As String

Private Function ConnectDatabase() As Integer
    Dim intResult As Integer

    On Error Resume Next

    If dbDatabase.State <> 1 Then
        'Connection to the database if closed, specify the database name, a username, and password
        strDatabase = "MyDB"
        strUserName = "MyUser"
        strPassword = "MyPassword"

        'Connect to the database
        'Oracle connection string
        dbDatabase.ConnectionString = "Provider=OraOLEDB.Oracle;Data Source=" & strDatabase & ";User ID=" & strUserName & ";Password=" & strPassword & ";ChunkSize=1000;FetchSize=100;"

        dbDatabase.ConnectionTimeout = 40
        dbDatabase.CursorLocation = adUseClient
        dbDatabase.Open

        If (dbDatabase.State <> 1) Or (Err <> 0) Then
            intResult = MsgBox("Could not connect to the database.  Check your user name and password." & vbCrLf & Error(Err), 16, "Excel Demo")

            ConnectDatabase = False
        Else
            ConnectDatabase = True
        End If
    Else
        ConnectDatabase = True
    End If
End Function

Private Sub Calculate()
    Const tvwChild = 4

    Dim i As Integer
    Dim sglPrice As Single
    Dim sglBasePrice As Single
    Dim sglWoodPriceMultiplier As Single

    tvBillOfMaterial.Nodes.Clear

    If (lstWoodType.ListIndex >= 0) And (lstCabinetType.ListIndex >= 0) Then
        Select Case lstCabinetType.List(lstCabinetType.ListIndex)
            Case "Base Cabinet Full Depth"
                tvBillOfMaterial.Nodes.Add , , "Door", "Door"
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DStile1", "Stile 1" & "   " & "3/4 X 2 X 30" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DStile2", "Stile 2" & "   " & "3/4 X 2 X 30" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DRail1", "Rail 1" & "   " & "3/4 X 2 X 21 3/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DRail2", "Rail 2" & "   " & "3/4 X 2 X 21 3/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DPanel", "Panel" & "   " & "5/8 X 21 3/4 X 27 3/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)

                tvBillOfMaterial.Nodes.Add , , "Case", "Case"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CStile1", "Stile 1" & "   " & "3/4 X 2 X 31" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CStile2", "Stile 2" & "   " & "3/4 X 2 X 31" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CRail1", "Rail 1" & "   " & "3/4 X 2 X 24" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CRail2", "Rail 2" & "   " & "3/4 X 2 X 24" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CKicker", "Kicker" & "   " & "5/8 X 21 3/4 X 27 3/4" & "   " & "Particle Board"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CSide1", "Side 1" & "   " & "3/4 X 24 X 35" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CSide2", "Side 2" & "   " & "3/4 X 24 X 35" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CBack", "Back" & "   " & "3/4 X 22 1/2 X 35" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CTop", "Top" & "   " & "3/4 X 22 1/2 X 23 1/4" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CBottom", "Bottom" & "   " & "3/4 X 22 1/2 X 23 1/4" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"

                sglBasePrice = 150
            Case "Base Cabinet Half Depth"
                tvBillOfMaterial.Nodes.Add , , "Door", "Door"
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DStile1", "Stile 1" & "   " & "3/4 X 2 X 30" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DStile2", "Stile 2" & "   " & "3/4 X 2 X 30" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DRail1", "Rail 1" & "   " & "3/4 X 2 X 21 3/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DRail2", "Rail 2" & "   " & "3/4 X 2 X 21 3/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DPanel", "Panel" & "   " & "5/8 X 21 3/4 X 27 3/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)

                tvBillOfMaterial.Nodes.Add , , "Case", "Case"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CStile1", "Stile 1" & "   " & "3/4 X 2 X 31" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CStile2", "Stile 2" & "   " & "3/4 X 2 X 31" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CRail1", "Rail 1" & "   " & "3/4 X 2 X 24" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CRail2", "Rail 2" & "   " & "3/4 X 2 X 24" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CKicker", "Kicker" & "   " & "5/8 X 21 3/4 X 27 3/4" & "   " & "Particle Board"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CSide1", "Side 1" & "   " & "3/4 X 12 X 35" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CSide2", "Side 2" & "   " & "3/4 X 12 X 35" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CBack", "Back" & "   " & "3/4 X 22 1/2 X 35" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CTop", "Top" & "   " & "3/4 X 22 1/2 X 11 1/4" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CBottom", "Bottom" & "   " & "3/4 X 22 1/2 X 11 1/4" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"

                sglBasePrice = 120
            Case "Full Height Base Cabinet"
                tvBillOfMaterial.Nodes.Add , , "Door", "Door"
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DStile1", "Stile 1" & "   " & "3/4 X 2 X 67" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DStile2", "Stile 2" & "   " & "3/4 X 2 X 67" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DRail1", "Rail 1" & "   " & "3/4 X 2 X 21 3/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DRail2", "Rail 2" & "   " & "3/4 X 2 X 21 3/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DPanel", "Panel" & "   " & "5/8 X 21 3/4 X 63 1/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)

                tvBillOfMaterial.Nodes.Add , , "Case", "Case"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CStile1", "Stile 1" & "   " & "3/4 X 2 X 72" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CStile2", "Stile 2" & "   " & "3/4 X 2 X 72" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CRail1", "Rail 1" & "   " & "3/4 X 2 X 24" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CRail2", "Rail 2" & "   " & "3/4 X 2 X 24" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CKicker", "Kicker" & "   " & "5/8 X 21 3/4 X 27 3/4" & "   " & "Particle Board"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CSide1", "Side 1" & "   " & "3/4 X 24 X 72" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CSide2", "Side 2" & "   " & "3/4 X 24 X 72" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CBack", "Back" & "   " & "3/4 X 22 1/2 X 72" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CTop", "Top" & "   " & "3/4 X 22 1/2 X 23 1/4" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CBottom", "Bottom" & "   " & "3/4 X 22 1/2 X 23 1/4" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"

                sglBasePrice = 250
            Case "Upper Cabinet"
                tvBillOfMaterial.Nodes.Add , , "Door", "Door"
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DStile1", "Stile 1" & "   " & "3/4 X 2 X 9 1/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DStile2", "Stile 2" & "   " & "3/4 X 2 X 9 1/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DRail1", "Rail 1" & "   " & "3/4 X 2 X 21 3/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DRail2", "Rail 2" & "   " & "3/4 X 2 X 21 3/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DPanel", "Panel" & "   " & "5/8 X 21 3/4 X 9 1/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)

                tvBillOfMaterial.Nodes.Add , , "Case", "Case"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CStile1", "Stile 1" & "   " & "3/4 X 2 X 12" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CStile2", "Stile 2" & "   " & "3/4 X 2 X 12" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CRail1", "Rail 1" & "   " & "3/4 X 2 X 24" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CRail2", "Rail 2" & "   " & "3/4 X 2 X 24" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CSide1", "Side 1" & "   " & "3/4 X 11 1/4 X 12" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CSide2", "Side 2" & "   " & "3/4 X 11 1/4 X 12" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CBack", "Back" & "   " & "3/4 X 22 1/2 X 12" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CTop", "Top" & "   " & "3/4 X 22 1/2 X 11 1/4" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CBottom", "Bottom" & "   " & "3/4 X 22 1/2 X 11 1/4" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"

                sglBasePrice = 100
            Case "Upper Cabinet Narrow"
                tvBillOfMaterial.Nodes.Add , , "Door", "Door"
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DStile1", "Stile 1" & "   " & "3/4 X 2 X 9 1/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DStile2", "Stile 2" & "   " & "3/4 X 2 X 9 1/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DRail1", "Rail 1" & "   " & "3/4 X 2 X 9 3/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DRail2", "Rail 2" & "   " & "3/4 X 2 X 9 3/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Door", tvwChild, "DPanel", "Panel" & "   " & "5/8 X 9 3/4 X 9 1/4" & "   " & lstWoodType.List(lstWoodType.ListIndex)

                tvBillOfMaterial.Nodes.Add , , "Case", "Case"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CStile1", "Stile 1" & "   " & "3/4 X 2 X 12" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CStile2", "Stile 2" & "   " & "3/4 X 2 X 12" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CRail1", "Rail 1" & "   " & "3/4 X 2 X 12" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CRail2", "Rail 2" & "   " & "3/4 X 2 X 12" & "   " & lstWoodType.List(lstWoodType.ListIndex)
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CSide1", "Side 1" & "   " & "3/4 X 11 1/4 X 12" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CSide2", "Side 2" & "   " & "3/4 X 11 1/4 X 12" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CBack", "Back" & "   " & "3/4 X 10 1/2 X 12" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CTop", "Top" & "   " & "3/4 X 10 1/2 X 11 1/4" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"
                tvBillOfMaterial.Nodes.Add "Case", tvwChild, "CBottom", "Bottom" & "   " & "3/4 X 10 1/2 X 11 1/4" & "   " & lstWoodType.List(lstWoodType.ListIndex) & " Plywood"

                sglBasePrice = 60
        End Select

        Select Case lstWoodType.List(lstWoodType.ListIndex)
            Case "Birch"
                sglWoodPriceMultiplier = 3.2
            Case "Cedar"
                sglWoodPriceMultiplier = 2.4
            Case "Cherry"
                sglWoodPriceMultiplier = 6
            Case "Douglas Fir"
                sglWoodPriceMultiplier = 2.8
            Case "Ebony"
                sglWoodPriceMultiplier = 12
            Case "Maple"
                sglWoodPriceMultiplier = 3.3
            Case "Pine"
                sglWoodPriceMultiplier = 1.5
            Case "Poplar"
                sglWoodPriceMultiplier = 1.3
            Case "Red Oak"
                sglWoodPriceMultiplier = 2.5
            Case "Redwood"
                sglWoodPriceMultiplier = 6
            Case "Spruce"
                sglWoodPriceMultiplier = 1
            Case "White Oak"
                sglWoodPriceMultiplier = 3
        End Select

        If sglPriceMarkup = 0 Then
            sglPriceMarkup = 0.3
        End If

        sglPrice = Round((sglBasePrice * sglWoodPriceMultiplier) * (1 + sglPriceMarkup), 2)

        txtSalesPrice = Format(sglPrice, "$0.00")
        txtManufactureCost = Format(Round((sglBasePrice * sglWoodPriceMultiplier), 2), "$0.00")
    End If

    For i = 1 To tvBillOfMaterial.Nodes.Count
        'Force all of the nodes to appear expanded
        tvBillOfMaterial.Nodes(i).Expanded = True
    Next i
    If tvBillOfMaterial.Nodes.Count > 0 Then
        tvBillOfMaterial.Nodes(1).Selected = True
    End If
End Sub

Private Sub cmdExit_Click()
    'Set the variable to indicate that the user did not force the window to close
    intFormCancelled = False

    'Make the form disappear
    Me.Hide
End Sub

Private Sub lstCabinetType_Click()
    Calculate
End Sub

Private Sub lstWoodType_Click()
    Calculate
End Sub

Private Sub UserForm_Initialize()
    Dim lngResult As Long
    Dim strSQL As String
    Dim snpData As ADODB.Recordset

    On Error Resume Next

    Set snpData = New ADODB.Recordset

    lngResult = ConnectDatabase

    If lngResult = True Then
        strSQL = "SELECT" & vbCrLf
        strSQL = strSQL & "  WOOD_TYPE" & vbCrLf
        strSQL = strSQL & "FROM" & vbCrLf
        strSQL = strSQL & "  CABINET_BUILDER_WOOD" & vbCrLf
        strSQL = strSQL & "ORDER BY" & vbCrLf
        strSQL = strSQL & "  WOOD_TYPE"
        snpData.Open strSQL, dbDatabase

        If snpData.State = 1 Then
            Do While Not snpData.EOF
                lstWoodType.AddItem snpData("wood_type")

                snpData.MoveNext
            Loop

            snpData.Close
        End If

        strSQL = "SELECT" & vbCrLf
        strSQL = strSQL & "  CABINET_TYPE" & vbCrLf
        strSQL = strSQL & "FROM" & vbCrLf
        strSQL = strSQL & "  CABINET_BUILDER_CAB_TYPE" & vbCrLf
        strSQL = strSQL & "ORDER BY" & vbCrLf
        strSQL = strSQL & "  CABINET_TYPE"
        snpData.Open strSQL, dbDatabase

        If snpData.State = 1 Then
            Do While Not snpData.EOF
                lstCabinetType.AddItem snpData("cabinet_type")

                snpData.MoveNext
            Loop

            snpData.Close
        End If
    End If

    Set snpData = Nothing
    'lstWoodType.List = Array("Birch", "Cedar", "Cherry", "Douglas Fir", "Ebony", "Maple", "Pine", "Poplar", "Red Oak", "Redwood", "Spruce", "White Oak")
    'lstCabinetType.List = Array("Base Cabinet Full Depth", "Base Cabinet Half Depth", "Full Height Base Cabinet", "Upper Cabinet", "Upper Cabinet Narrow")
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    'Prevent the form from being unloaded
    Cancel = True

    'Set the variable to indicate that the user closed the window
    intFormCancelled = True

    'Make the form disappear
    Me.Hide
End Sub

To keep matters simple, I elected to not pull up the costs for the various cabinets, the price premiums for different wood types, or the bill of material from the database.  If all was successful, at this point you should be able to type the following into the Immediate Window to show the userform:

a = ShowCabinetBuilder( 1 )

Almost done, now we just need the VBS script that will interact with the Excel workbook.  Use Notepad to create a new text file named “C:\ExcelMacroFunctionsDemo.vbs” and add the following code:

Dim i
Dim objExcel
Dim objShell
Dim sglResult
Dim strResult
Dim strBOM
Dim strMaterial
Dim strOut
Dim strOpenDate
Dim strVendorID

Set objExcel = CreateObject("Excel.Application")

strOpenDate = cDate("January 7, 2010")
strVendorID = "MyCompanyHere"

strOut = ""
With objExcel
    'Open the Excel file containing the macro functions
    .Workbooks.Open "C:\ExcelMacroFunctionDemo.xls"

    'Excute a standard macro located in mdlGlobal, pass in the vendor ID from Visual
    strResult = .Application.Run("ReverseString", strVendorID)
    strOut = strOut & "Execute a Custom Excel Macro:" & vbCrLf
    strOut = strOut & " The vendor ID spelled backward is " & strResult & vbCrLf

    'Excute a macro located in mdlGlobal that calls an internal Excel function
    strResult = .Application.Run("ToRoman", Year(strOpenDate))
    strOut = strOut & vbCrLf & "Execute a Custom Excel Macro - Calls Int. Excel Func:" & vbCrLf
    strOut = strOut & " The open date year in Roman numerals is " & strResult & vbCrLf

    'Excute a macro located in mdlGlobal that calls an internal Excel function, function not available on Excel 2003
    'strResult = .Application.Run("ToHexadecimal", Year(strOpenDate))
    'strOut = strOut & "The open date year in Hexadecimal is " & strResult & vbCrLf

    'Excute a macro located in mdlGlobal that calls an internal Excel function
    strResult = .Application.Run("CalculateCombinations", 5, 3)
    strOut = strOut & " There are " & strResult & " cominations of 5 objects arranged in 3 slots" & vbCrLf
    strResult = .Application.Run("CalculateCombinations", 5, 4)
    strOut = strOut & " There are " & strResult & " cominations of 5 objects arranged in 4 slots" & vbCrLf
    strResult = .Application.Run("CalculatePermutations", 5, 3)
    strOut = strOut & " There are " & strResult & " permutations of 5 objects arranged in 3 slots" & vbCrLf
    strResult = .Application.Run("CalculatePermutations", 5, 4)
    strOut = strOut & " There are " & strResult & " permutations of 5 objects arranged in 4 slots" & vbCrLf

    'Excute a macro located in mdlGlobal that calls an internal Excel function with multiple parameters
    sglResult = .Application.Run("CalculateInterestPayment", 0.07, 12, 4 * 12, 30000)
    strOut = strOut & " A monthly payment on a $30,000 loan at 7% interest is $" & FormatNumber(sglResult, 2) & " for 4 years" & vbCrLf   

    'Directly execute an internal Excel function, function not available on Excel 2003
    'sglResult = .Application.WorksheetFunction.NetworkDays(Date, cDate("12/31/" & cStr(Year(Now))))
    'strOut = strOut & "There are " & cStr(sglResult) & " week days left in the year" & vbCrLf

    'Directly execute an internal Excel function
    strOut = strOut & vbCrLf & "Directly Execute Internal Excel Func:" & vbCrLf
    sglResult = .Application.WorksheetFunction.Average(10,3,4,5,6,100)
    strOut = strOut & " The average of 10,3,4,5,6,100 is " & cStr(sglResult) & vbCrLf
    sglResult = .Application.WorksheetFunction.Product(10,3,4,5,6,100)
    strOut = strOut & " The product of 10,3,4,5,6,100 is " & cStr(sglResult) & vbCrLf
    sglResult = .Application.WorksheetFunction.StDev(10,3,4,5,6,100)
    strOut = strOut & " The standard deviation of 10,3,4,5,6,100 is " & cStr(sglResult) & vbCrLf
    MsgBox strOut, vbInformation, "Excel Macro Functions"

    strOut = ""
    'Excute a macro located in mdlGlobal that retrieves a value from one of Visual's INI files
    strOut = strOut & "Read Values from Visual INIs:" & vbCrLf
    strResult = .Application.Run("VisualINIGet", "PlanningWindow", "ShowUnreleased", "Visual.ini")
    If (Left(Ucase(strResult), 1) = "Y") Or (Left(Ucase(strResult), 1) = "1") Then
        strOut = strOut & " The Material Planning Window will show Unreleased orders" & vbCrLf
    Else
        strOut = strOut & " The Material Planning Window will show Not Unreleased orders" & vbCrLf
    End IF
    strResult = .Application.Run("VisualINIGet", "Work Orders", "table", "vmbrowse.ini")
    strOut = strOut & " WO Browse tables=: " & strResult & vbCrLf
    strResult = .Application.Run("VisualINIGet", "Work Orders", "where", "vmbrowse.ini")
    strOut = strOut & " WO Browse where=: " & strResult & vbCrLf
    strResult = .Application.Run("VisualINIGet", "Work Orders", "decode", "vmbrowse.ini")
    strOut = strOut & " WO Browse columns=: " & strResult & vbCrLf
    MsgBox strOut, vbInformation, "Excel Macro Functions"

    strOut = ""
    'Excute a macro located in mdlGlobal that retrieves values from the registry
    strOut = strOut & "Read Values from Windows Registry:" & vbCrLf
    strResult = .Application.Run("RegistryGetEntry", "Control Panel\Desktop", "Wallpaper")
    strOut = strOut & " Desktop Picture: " & strResult & vbCrlf

    'Excute a macro located in mdlGlobal that retrieves environment variables
    strOut = strOut & vbCrLf & "Read Values from Windows Env Variables:" & vbCrLf
    strResult = .Application.Run("EnvironmentVariable", "username")
    strOut = strOut & " User: " & strResult
    strResult = .Application.Run("EnvironmentVariable", "computername")
    strOut = strOut & " is logged into the computer: " & strResult
    strResult = .Application.Run("EnvironmentVariable", "windir")
    strOut = strOut & " with the Windows folder located in: " & strResult
    strResult = .Application.Run("EnvironmentVariable", "temp")
    strOut = strOut & " and the temp folder is located in: " & strResult
    MsgBox strOut, vbInformation, "Excel Macro Functions"

    'Show an Excel user form by calling a public macro function in the located in mdlGlobal module
    strResult = InputBox("Enter Markup Percent (for example  50) for Cabinet Builder", "Excel Macro Functions")
    If IsNumeric(strResult) Then
        'with the help of custom program, set a 1 second delay, then force the window to the top
        Set objShell = CreateObject("WScript.Shell")
        objShell.Run("C:\BringToTop.exe " & Chr(34) & "Cabinet Builder" & Chr(34) & " 1")

        strBOM = .Application.Run("ShowCabinetBuilder", cSng(strResult) / 100)

        Set objShell = Nothing

        'BOM is tab delimited, split apart
        strMaterial = Split(cStr(strBOM), vbTab)

        strOut = "Show an Excel user form on demand:" & vbCrLf
        strOut = strOut & "Bill of Material" & vbCrLf     

        For i = 0 To UBound(strMaterial)
            strOut = strOut & strMaterial(i) & vbCrLf
        Next

        MsgBox strOut, vbInformation, "Excel Macro Functions"
    End If
End With

objExcel.DisplayAlerts = False
objExcel.ActiveWorkbook.Saved = True
objExcel.Quit
Set objExcel = Nothing  

Now for a test run.  Save the Excel worksheet and exit Excel.  In Windows Explorer, double-click the C:\ExcelMacroFunctionDemo.vbs file.  The second screen capture will likely be blank if you try to run the script as it is, but my output looks like the following:

Clicking OK displayed the following on my computer, but it will probably be blank on your computer:

Clicking OK causes the VBS macro to access the Excel macro code that retrieves information from the Windows registry and environment variables:

Next, the computer will ask for a mark up percent.  Specify a value, such as 50 or 100:

Next, the cabinet builder interface appears.  Pick a type of wood and a cabinet type.  The percentage specified earlier will be multiplied by the manufacture cost to arrive at the sales price.  A fake bill of material will appear near the bottom of the window.

When the Exit button is clicked, the bill of material is returned to the VBS script, and then displayed on the screen.

While this specific example might not be very useful, it does demonstrate how to use an Excel userform as an interface for a VBS script – and the username and password used to access the database are not in clear text in the VBS script.

Shortcut: save all of the following in the root of the C:\ drive and remove the .doc extension at the end of the filenames.

ExcelMacroFunctionDemo.xls

ExcelMacroFunctionDemo.vbs

BringToTop.exe (only needed on Vista and Windows 7)


Actions

Information

One response

22 04 2011
» Best Oracle Peformance Tools?

[...] Shows how to create a UserForm in Excel and display that UserForm using a VBS script: http://hoopercharles.wordpress.com/2010/02/07/excel-userforms-with-database-access-called-from-vbs/ Windows Vista and Windows 7 gadget: [...]

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s




Follow

Get every new post delivered to your Inbox.

Join 139 other followers

%d bloggers like this: