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)
Charles Hooper's Oracle Notes 
Recent Comments