Extract 1834 Images from Excel 2007 and Transfer to a Database Table

28 12 2009

December 28, 2009

(Portions of this code are adapted from the book “Excel 2007 Power Programming with VBA”  )

This code sample is an Excel 2007 macro that extracts all of the named toolbar button pictures from Excel 2007, transfers those pictures to an Oracle database (stored in a BLOB), and then retrieves each of the pictures and displays the pictures on an Excel worksheet.

First, we need to create a table to hold the pictures:

CREATE TABLE EXCEL2007_TOOLBAR_PICTURES (
  PICTURE_NAME VARCHAR2(60),
  PICTURE_SIZE NUMBER,
  PICTURE BLOB,
  PRIMARY KEY(PICTURE_NAME));

Download the ExcelImageList.doc file and save it using Microsoft Word as a Plain Text File with the name ExcelImageList.txt in the root of the C:\ drive.

We need to make certain that macro support is enabled in Excel 2007, by default it is disabled.  Follow steps 1 through 3 to verify that the Developer tab appears at the top of the screen:

On the Developer tab, click the Visual Basic button.  We need to add a reference to the Microsoft ActiveX Data Objects to allow the macro to interact with an Oracle database.  From the Tools menu, select References…

Locate one of the recent releases of Microsoft ActiveX Data Objects, select it, then click OK.

Finally, we create the following macro:

Private Sub ExtractAllImages()
    Dim i As Integer
    Dim intResult As Integer
    Dim intFileNum As Integer
    Dim intFileNum2 As Integer
    Dim sglX As Single
    Dim sglY As Single
    Dim strName As String
    Dim strSQL As String
    Dim strDatabase As String
    Dim strUserName As String
    Dim strPassword As String
    Dim bytPicture() As Byte

    Dim imgPicture As OLEObject
    Dim snpData As New ADODB.Recordset
    Dim dynData As New ADODB.Recordset
    Dim dbDatabase As New ADODB.Connection

    On Error Resume Next

    'Remove all of the previously created sheet
    Application.DisplayAlerts = False
    Sheets("BuiltInImages").Delete

    Sheets.Add
    ActiveSheet.Name = "BuiltInImages"

    DoEvents
    Application.DisplayAlerts = True

    If Len(Dir("C:\ExcelBuiltInImages", vbDirectory)) < 4 Then
        'Create the folder to hold the exported pictures
        MkDir "C:\ExcelBuiltInImages"
    End If

    'Create a temporary image object to hold the pictures from GetImageMso
    Set imgPicture = Sheets("BuiltInImages").OLEObjects.Add(classtype:="Forms.Image.1", Left:=800, Top:=1, Width:=32, Height:=32)
    With imgPicture.Object
        .AutoSize = True
        .BorderStyle = 0
    End With

    Err = 0
    intFileNum = FreeFile
    Open "C:\ExcelImageList.txt" For Input As #intFileNum

    If Err <> 0 Then
        intResult = MsgBox("Could not open the image list file." & vbCrLf & Error(Err), 16, "Excel Demo")
        Exit Sub
    End If

    strDatabase = "MyDB" 'From tnsnames.ora
    strUserName = "MyUserID"
    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")
    End If

    'The table definition
    'CREATE TABLE EXCEL2007_TOOLBAR_PICTURES (
    '  PICTURE_NAME VARCHAR2(60),
    '  PICTURE BLOB,
    '  PRIMARY KEY(PICTURE_NAME));

    If Err = 0 Then
        'Remove pictures that were previously brought in
        strSQL = "DELETE FROM EXCEL2007_TOOLBAR_PICTURES"
        dbDatabase.Execute strSQL

        dbDatabase.BeginTrans

        'Prepare to add the new pictures to the database
        strSQL = "SELECT"
        strSQL = strSQL & "  PICTURE_NAME," & vbCrLf
        strSQL = strSQL & "  PICTURE_SIZE," & vbCrLf
        strSQL = strSQL & "  PICTURE" & vbCrLf
        strSQL = strSQL & "FROM" & vbCrLf
        strSQL = strSQL & "  EXCEL2007_TOOLBAR_PICTURES"
        dynData.Open strSQL, dbDatabase, adOpenKeyset, adLockOptimistic, adCmdText

        'Process each of the toolbar picture names from the text file
        Do While Not (EOF(intFileNum))
            i = i + 1
            'Read a toolbar picture name from the text file
            Line Input #intFileNum, strName
            Application.StatusBar = strName

            'Set the picture in the temporary image object, and then save to disk
            imgPicture.Object.Picture = Application.CommandBars.GetImageMso(strName, 32, 32)
            SavePicture imgPicture.Object.Picture, "C:\ExcelBuiltInImages\temp.bmp"

             'Create a new row in the table
            dynData.AddNew
            dynData("picture_name") = strName & ".bmp"
            dynData("picture_size") = FileLen("C:\ExcelBuiltInImages\temp.bmp")

            'Read the picture into the table
            intFileNum2 = FreeFile
            Open "C:\ExcelBuiltInImages\temp.bmp" For Binary As #intFileNum2

            'Prepare a variable of byte data type to hold the picture read from disk
            ReDim bytPicture(FileLen("C:\ExcelBuiltInImages\temp.bmp"))
            Get #intFileNum2, , bytPicture
            Close #intFileNum2

            'Write the picture into the table and save the row
            dynData.Fields("picture").AppendChunk bytPicture
            dynData.Update

            'Delete the picture from the folder
            Kill "C:\ExcelBuiltInImages\temp.bmp"
        Loop
        Application.StatusBar = ""

        dbDatabase.CommitTrans

        dynData.Close

        Close #intFileNum

        'Remove the temporary image object
        imgPicture.Delete

        'Retrieve the pictures from the database and display in Excel
        i = 0
        strSQL = "SELECT" & vbCrLf
        strSQL = strSQL & "  PICTURE_NAME," & vbCrLf
        strSQL = strSQL & "  PICTURE_SIZE," & vbCrLf
        strSQL = strSQL & "  PICTURE" & vbCrLf
        strSQL = strSQL & "FROM" & vbCrLf
        strSQL = strSQL & "  EXCEL2007_TOOLBAR_PICTURES" & vbCrLf
        strSQL = strSQL & "ORDER BY" & vbCrLf
        strSQL = strSQL & "  PICTURE_NAME"
        snpData.Open strSQL, dbDatabase

        If Not (snpData.EOF) Then
            Do While Not (snpData.EOF)
                i = i + 1
                Application.StatusBar = snpData("picture_name")

                'Retrieve the picture from the database and write to a file

                ReDim bytPicture(snpData("picture_size"))
                bytPicture = snpData("picture")
                intFileNum2 = FreeFile
                Open "C:\ExcelBuiltInImages\" & snpData("picture_name") For Binary As #intFileNum2
                Put #intFileNum2, , bytPicture
                Close #intFileNum2

                'There will be 20 pictures across the page, so identify the top left position of the picture
                sglX = ((i - 1) Mod 20) * 36
                sglY = Int((i - 1) / 20) * 36

                'Create the shape object and load the picture that was saved from the image object
                With Sheets("BuiltInImages").Shapes.AddShape(Type:=msoShapeRectangle, Left:=sglX, Top:=sglY, Width:=30, Height:=30)
                    .Line.Visible = False
                    .Fill.UserPicture "C:\ExcelBuiltInImages\" & snpData("picture_name")
                    .AlternativeText = snpData("picture_name")
                End With

                'Allow Excel to refresh the screen as every four rows complete
                If i Mod 80 = 0 Then
                    Application.ScreenUpdating = True
                    DoEvents
                    Application.ScreenUpdating = False
                End If

                snpData.MoveNext
            Loop
            snpData.Close
        End If
    End If
    Application.ScreenUpdating = True
    Application.StatusBar = ""
    dbDatabase.Close

    'Clean up
    Set snpData = Nothing
    Set dynData = Nothing
    Set dbDatabase = Nothing
    Set imgPicture = Nothing
End Sub

When the macro runs, it saves each of the built-in toolbar icons to a file named temp.bmp, and then inserts a row into the database table with the temp.bmp picture.  Once all of the pictures are stored in the database, a query is run to retrieve each of the pictures, create a file in ExcelBuiltInImages folder for that picture, and then display the picture in Excel.  The screen is refreshed after every 80 pictures are displayed.  Note that most of the built-in toolbar icons are designed to be viewed at a size of 16 pixels by 16 pixels, rather than 32 pixels by 32 pixels – so the images may appear a bit “blocky”.  The picture filenames are stored in the Alt Text property of each picture, which may be viewed by right-clicking a picture and selecting Size and Properties…

After the macro runs, the new worksheet will look something like the picture below:

Since the pictures are also saved to a file, they are ready to be used for other purposes:





Print Oracle Data to a Barcode Label with a Zebra Printer using VBS and Excel

12 12 2009

December 12, 2009

Here is the problem: You know how to query the database using a Windows Scripting Host VBS file, but you have no way to print a barcode label using the data to the networked Zebra label printer and there is no printer driver installed for the Zebra printer.  Fortunately, Zebra printers understand ZPL (Zebra Printer Langauge), so we are able to easily work around the issue of not having a driver for the printer installed.  The second problem is how do we send the print job to the printer?  This is where Excel comes to the rescue.  Excel is able to work with the Windows API to start and submit a print job to a printer that is not necessarily installed on the local computer.

First, the Windows Scripting Host VBS file (note that this uses a DLL that I wrote which hides the database name, username, and password, as well as simplifying the process of submitting SQL statements with bind variables to the database):

'PrintLabel.vbs
Dim intParentPartLine
Dim strRawText
Dim strSQL
Dim strWhereUsed
Dim snpData
Dim OracleSQL
Dim objExcel

On Error Resume Next

Set OracleSQL = CreateObject("VMDBOracle.SQLProcessor") 'This is my custom DLL
Set snpData = CreateObject("ADODB.Recordset")
Set objExcel = CreateObject("Excel.Application")

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

    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 & "^LH12,30" 'Label home position in pixels
    strRawText = strRawText & "^FO5,0^A0,40,40^FD" & ID & "^FS" 'Proportional font
    strRawText = strRawText & "^FO5,40^A0,20,20^FD" & DESCRIPTION & "^FS" 'Proportional font
    strRawText = strRawText & "^FO5,80^A0,15,15^FD**** WHERE USED ****^FS" ' 'Proportional font

    strSQL = "SELECT DISTINCT" & vbCrLf
    strSQL = strSQL & "  R.WORKORDER_BASE_ID AS TOP_PART_ID," & vbCrLf
    strSQL = strSQL & "  WO.PART_ID AS SUB_PART_ID" & vbCrLf
    strSQL = strSQL & "FROM" & vbCrLf
    strSQL = strSQL & "  REQUIREMENT R," & vbCrLf
    strSQL = strSQL & "  WORK_ORDER WO" & vbCrLf
    strSQL = strSQL & "WHERE" & vbCrLf
    strSQL = strSQL & "  WO.TYPE='M'" & vbCrLf
    strSQL = strSQL & "  AND R.WORKORDER_TYPE='M'" & vbCrLf
    strSQL = strSQL & "  AND R.PART_ID= ?" & vbCrLf
    strSQL = strSQL & "  AND R.WORKORDER_TYPE=WO.TYPE" & vbCrLf
    strSQL = strSQL & "  AND R.WORKORDER_BASE_ID=WO.BASE_ID" & vbCrLf
    strSQL = strSQL & "  AND R.WORKORDER_LOT_ID=WO.LOT_ID" & vbCrLf
    strSQL = strSQL & "  AND R.WORKORDER_SPLIT_ID=WO.SPLIT_ID" & vbCrLf
    strSQL = strSQL & "  AND R.WORKORDER_SUB_ID=WO.SUB_ID" & vbCrLf
    strSQL = strSQL & "ORDER BY" & vbCrLf
    strSQL = strSQL & "  R.WORKORDER_BASE_ID," & vbCrLf
    strSQL = strSQL & "  WO.PART_ID"
    OracleSQL.SQL = strSQL
    OracleSQL.SetParameter ID, "VARCHAR"

    Set snpData = OracleSQL.Execute

    If Not (snpData Is Nothing) Then
        If Not (snpData.EOF) Then
            intParentPartLine = 0
            Do While Not (snpData.EOF)
                intParentPartLine = intParentPartLine + 1
                If snpData("top_part_id") <> snpData("sub_part_id") Then
                    strWhereUsed = strWhereUsed & cStr(snpData("top_part_id")) & " (Sub " & cStr(snpData("sub_part_id")) & ")"
                Else
                    strWhereUsed = strWhereUsed & cStr(snpData("top_part_id"))
                End If
                strRawText = strRawText & "^FO10," & cStr(80 + 25 * intParentPartLine) & "^A0,25,25^FD" & strWhereUsed & "^FS" 'Proportional font
                strWhereUsed  = ""

                snpData.MoveNext
            Loop
        End If

        snpData.Close
    End If

    strRawText = strRawText & "^FO20,562^AF^FDMy Company Here^FS"
    strRawText = strRawText & "^XZ"  'End of label indicator

    'Excute a macro located in mdlGlobal that prints a label using API calls
                                 'Subroutine, printer device name, raw ZPL code

    'Print to a shared Zebra printer named ZEBRA on computer named KMMACH98
    'strResult = .Application.Run("ZebraPrintLabel", "\\KMMACH98\ZEBRA", strRawText)

    'Print to a "Local" printer named ZEBRA_M1 with a redirected LTP2 port with NET USE
    strResult = .Application.Run("ZebraPrintLabel", "ZEBRA_M1", strRawText)

    .DisplayAlerts = False
    .ActiveWorkbook.Saved = True
    .Quit
End With

Set objExcel = Nothing 
Set OracleSQL = Nothing
Set snpData = Nothing
'End of PrintLabel.vbs

The above script expects to find an Excel spreadsheet named C:\ExcelMacroFunction.xls with a public subroutine named  ZebraPrintLabel in a regular Excel code module.

The code in the Excel code module looks like this:

'mdlGlobal in C:\ExcelMacroFunction.xls - a global module
Option Explicit

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

'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

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

    'Sample label for testing using just Excel
    'strPrinter = "\\KMMACH98\ZEBRA"
    '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 Here^FS" 'rotated text in font A
    'strRawText = strRawText & "^FO2,480^A0R,20,20^FDSomwhere, USA^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
'End of mdlGlobal

Note that while the above uses a custom DLL to connect to the database and submit SQL statements, the Simple VBS Script to Retrieve Data from Oracle blog entry shows how to do the same without using the custom DLL.  Also, it probably is not necessary to convert the Unicode string that is passes into the procedure into a byte stream for the Windows API call.

The printed label appears below:





Simple VBS Script to Retrieve Data from Oracle

12 12 2009

December 12, 2009

All recent releases of the Windows operating system include the Windows Scripting Host, which allows executing program commands that look much like the macro language used in Excel, Access, and Word, as well as the original line of Microsoft’s Visual Basic (before the introduction of .Net).  Scripts intended to be excuted by the Windows Scripting Host have an extension of .VBS and are executed either with cscript that outputs to a command line window, or the default wscript that outputs to Windows popup messages.

A simple script that connects to an Oracle database (without using ODBC), queries a table, and then performs a comparison on the values retrieved from the table follows:

'Save as ConnectDB.vbs
Dim strSQL
Dim strUsername
Dim strPassword
Dim snpData
Dim dbMyDBConnection
Dim ORDER_ID         'Note that this variable was omitted originally as it was automatically supplied by an ERP package

Set snpData = CreateObject("ADODB.Recordset")
Set dbMyDBConnection = CreateObject("ADODB.Connection")
strUsername = "MyUser"
strPassword = "MySecret"

dbMyDBConnection.ConnectionString = "Provider=OraOLEDB.Oracle;Data Source=MyDB;User ID=" & strUsername & ";Password=" & strPassword & ";"
dbMyDBConnection.Open

ORDER_ID = "MYORDERID123"  'Note that this variable value was omitted originally as it was automatically supplied by an ERP package
strSQL = "SELECT C1, C2 FROM MY_TABLE WHERE PURC_ORDER_ID='" & ORDER_ID & "'"

snpData.Open strSQL, dbMyDBConnection

If Not(snpData.EOF) Then
    If cInt(snpData("c1")) < cInt(snpData("c2")) Then
        MsgBox "C1 is Less than C2"
    End If
    If cInt(snpData("c1")) > cInt(snpData("c2")) Then
        MsgBox "C1 is Greater than C2"
    End If
    If cInt(snpData("c1")) = cInt(snpData("c2")) Then
        MsgBox "C1 is Equal to C2"
    End If

    MsgBox cInt(snpData("c1")) - cInt(snpData("c2"))
Else
    MsgBox "Ut oh, No Matching Records"
End If

snpData.Close
dbMyDBConnection.Close

Set snpData = Nothing
Set dbMyDBConnection = Nothing

Once the script is saved, double-clicking the script should automatically execute it using wscript.  Alternatively, open a Windows command prompt and type the following (assuming that the script is named ConnectDB.vbs and is saved in the root of the C:\ drive):

cscript c:\ConnectDB.vbs




Transfer a Text File into an Oracle Database using an Excel Macro

2 12 2009

December 2, 2009

The following Excel macro shows how to open a text file as a database using ADO, create a table in Oracle, and then transfer the rows from the text file into the database table using bind variables.  Once the transfer finishes, a worksheet in Excel is populated with the data from the Oracle table.

Private Sub TransferRows()
    'Need to add a reference to Microsoft ActiveX Data Objects 2.8 Library before starting
    Dim i As Integer
    Dim intResult As Integer
    Dim strSQL As String
    Dim strTable As String
    Dim strDBTable As String
    Dim snpData As ADODB.Recordset
    Dim comDataInsert As ADODB.Command

    On Error Resume Next

    strTable = Sheets("ExcelQueryofTextFile").Cells(1, 2).Value
    strTable = Right(strTable, Len(strTable) - InStrRev(strTable, "\"))
    'Set the database table name to the file name without the extension
    strDBTable = UCase(Left(strTable, InStr(strTable, ".") - 1))

    Sheets("ExcelQueryofTextFile").Range("A5:M10006").Delete Shift:=xlUp

    Set snpData = New ADODB.Recordset

    strSQL = "SELECT" & vbCrLf
    strSQL = strSQL & "  [Source IP Address]," & vbCrLf
    strSQL = strSQL & "  [Destination IP Address]," & vbCrLf
    strSQL = strSQL & "  [Time]," & vbCrLf
    strSQL = strSQL & "  [Source Port]," & vbCrLf
    strSQL = strSQL & "  [Destination Port]," & vbCrLf
    strSQL = strSQL & "  [L3 Protocol]," & vbCrLf
    strSQL = strSQL & "  [Application Path]," & vbCrLf
    strSQL = strSQL & "  [Application Description]," & vbCrLf
    strSQL = strSQL & "  [Rule Description]" & vbCrLf
    strSQL = strSQL & "FROM" & vbCrLf
    strSQL = strSQL & "  [" & strTable & "]" & vbCrLf
    strSQL = strSQL & "ORDER BY" & vbCrLf
    strSQL = strSQL & "  [Source IP Address]," & vbCrLf
    strSQL = strSQL & "  [Time]"
    snpData.Open strSQL, dbFile

    If snpData.State = 1 Then
        strSQL = "CREATE TABLE " & strDBTable & "(" & vbCrLf
        strSQL = strSQL & "  SOURCE_IP VARCHAR2(16)," & vbCrLf
        strSQL = strSQL & "  DESTINATION_IP VARCHAR2(16)," & vbCrLf
        strSQL = strSQL & "  ACCESS_TIME DATE," & vbCrLf
        strSQL = strSQL & "  SOURCE_PORT NUMBER(12)," & vbCrLf
        strSQL = strSQL & "  DESTINATION_PORT NUMBER(12)," & vbCrLf
        strSQL = strSQL & "  PROTOCOL VARCHAR2(15)," & vbCrLf
        strSQL = strSQL & "  APPLICATION_PATH VARCHAR2(100)," & vbCrLf
        strSQL = strSQL & "  APPLICATION_DESCRIPTION VARCHAR2(100)," & vbCrLf
        strSQL = strSQL & "  RULE_DESCRIPTION VARCHAR2(30))" & vbCrLf
        dbVMFG.Execute strSQL

        Set comDataInsert = New ADODB.Command
        With comDataInsert
            strSQL = "INSERT INTO " & strDBTable & "(" & vbCrLf
            strSQL = strSQL & "  SOURCE_IP," & vbCrLf
            strSQL = strSQL & "  DESTINATION_IP," & vbCrLf
            strSQL = strSQL & "  ACCESS_TIME," & vbCrLf
            strSQL = strSQL & "  SOURCE_PORT," & vbCrLf
            strSQL = strSQL & "  DESTINATION_PORT," & vbCrLf
            strSQL = strSQL & "  PROTOCOL," & vbCrLf
            strSQL = strSQL & "  APPLICATION_PATH," & vbCrLf
            strSQL = strSQL & "  APPLICATION_DESCRIPTION," & vbCrLf
            strSQL = strSQL & "  RULE_DESCRIPTION)" & vbCrLf
            strSQL = strSQL & "VALUES(" & vbCrLf
            strSQL = strSQL & "  ?," & vbCrLf
            strSQL = strSQL & "  ?," & vbCrLf
            strSQL = strSQL & "  ?," & vbCrLf
            strSQL = strSQL & "  ?," & vbCrLf
            strSQL = strSQL & "  ?," & vbCrLf
            strSQL = strSQL & "  ?," & vbCrLf
            strSQL = strSQL & "  ?," & vbCrLf
            strSQL = strSQL & "  ?," & vbCrLf
            strSQL = strSQL & "  ?)" & vbCrLf

            .Parameters.Append .CreateParameter("source_ip", adVarChar, adParamInput, 16)
            .Parameters.Append .CreateParameter("destination_ip", adVarChar, adParamInput, 16)
            .Parameters.Append .CreateParameter("access_time", adDate, adParamInput, 8 )
            .Parameters.Append .CreateParameter("source_port", adNumeric, adParamInput, 8 )
            .Parameters.Append .CreateParameter("destination_port", adNumeric, adParamInput, 8 )
            .Parameters.Append .CreateParameter("protocol", adVarChar, adParamInput, 15)
            .Parameters.Append .CreateParameter("application_path", adVarChar, adParamInput, 100)
            .Parameters.Append .CreateParameter("application_description", adVarChar, adParamInput, 100)
            .Parameters.Append .CreateParameter("rule_description", adVarChar, adParamInput, 30)

            'Set up the command properties
            .CommandText = strSQL
            .CommandType = adCmdText
            .CommandTimeout = 30
            .ActiveConnection = dbVMFG
        End With

        If Err = 0 Then
            dbVMFG.BeginTrans
            Do While Not snpData.EOF
                comDataInsert("source_ip") = snpData(0).Value
                comDataInsert("destination_ip") = snpData(1).Value
                comDataInsert("access_time") = CDate(snpData(2).Value)
                comDataInsert("source_port") = Val(snpData(3).Value)
                comDataInsert("destination_port") = Val(snpData(4).Value)
                comDataInsert("protocol") = Left(snpData(5).Value, 15)
                comDataInsert("application_path") = Left(snpData(6).Value, 100)
                comDataInsert("application_description") = Left(snpData(7).Value, 100)
                comDataInsert("rule_description") = Left(snpData(8).Value, 30)
                comDataInsert.Execute

                snpData.MoveNext
            Loop

            snpData.Close
            If Err = 0 Then
                dbVMFG.CommitTrans
            Else
                dbVMFG.RollbackTrans
            End If

            strSQL = "SELECT" & vbCrLf
            strSQL = strSQL & "  SOURCE_IP," & vbCrLf
            strSQL = strSQL & "  DESTINATION_IP," & vbCrLf
            strSQL = strSQL & "  ACCESS_TIME," & vbCrLf
            strSQL = strSQL & "  SOURCE_PORT," & vbCrLf
            strSQL = strSQL & "  DESTINATION_PORT," & vbCrLf
            strSQL = strSQL & "  PROTOCOL," & vbCrLf
            strSQL = strSQL & "  APPLICATION_PATH," & vbCrLf
            strSQL = strSQL & "  APPLICATION_DESCRIPTION," & vbCrLf
            strSQL = strSQL & "  RULE_DESCRIPTION" & vbCrLf
            strSQL = strSQL & "FROM" & vbCrLf
            strSQL = strSQL & "  " & strDBTable & vbCrLf
            strSQL = strSQL & "ORDER BY" & vbCrLf
            strSQL = strSQL & "  SOURCE_IP," & vbCrLf
            strSQL = strSQL & "  ACCESS_TIME"
            snpData.Open strSQL, dbVMFG

            If snpData.State = 1 Then
                'The fast way to place the query results into cells
                For i = 0 To snpData.Fields.Count - 1
                    Sheets("ExcelQueryofTextFile").Cells(5, i + 1).Value = snpData.Fields(i).Name
                Next i
                Sheets("ExcelQueryofTextFile").Range(Sheets("ExcelQueryofTextFile").Cells(5, 1), Sheets("ExcelQueryofTextFile").Cells(5, snpData.Fields.Count)).Font.Bold = True

                Sheets("ExcelQueryofTextFile").Range("A6").CopyFromRecordset snpData

                snpData.Close

            End If
        Else
            intResult = MsgBox("Could not create the table " & strDBTable & " in the database." & vbCrLf & Error(Err), 16, "Excel Demo")
        End If
    End If

    Sheets("ExcelQueryofTextFile").Range("A6").Select
    ActiveWindow.FreezePanes = True

    Set snpData = Nothing
    Set comDataInsert = Nothing
End Sub




Retrieve Data to Excel with a Macro using ADO

2 12 2009

The following Excel macro shows how to connect to an Oracle database using ADO, create a new worksheet in the current work book, and then fill in the returned data using a slow method (not recommended) and a fast method.

'Need to add a reference to Microsoft ActiveX Data Objects 2.8 Library before starting
'*** This section might be in the top portion of the user form, worksheet code, or module:
'Declare a connection object in the general section to hold the connection to the database
Dim dbVMFG As ADODB.Connection
 
'Declare a set of variables to hold the username and password for the database
Dim strUserName As String
Dim strPassword As String
Dim strDatabase As String
'***
 
Dim i as Integer
Dim intResult As Integer
Dim strSQL as String
Dim lngRow as Long
    
On Error Resume Next
 
strDatabase = "MyDB"
 
strUserName = "MyUser"
strPassword = "MyPassword"
 
'Connect to the database
'Oracle connection string
Set dbVMFG = New ADODB.Connection
dbVMFG.ConnectionString = "Provider=OraOLEDB.Oracle;Data Source=" & strDatabase & ";User ID=" & strUserName & ";Password=" & strPassword & ";ChunkSize=1000;FetchSize=100;"
 
dbVMFG.ConnectionTimeout = 40
dbVMFG.CursorLocation = adUseClient
dbVMFG.Open
 
If (dbVMFG.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")
Else
    strSQL = "SELECT" & VBCrLf
    strSQL = strSQL & "  ID AS RESOURCE_ID," & VBCrLf
    strSQL = strSQL & "  DESCRIPTION" & VBCrLf
    strSQL = strSQL & "FROM" & VBCrLf
    strSQL = strSQL & "  MY_TABLE" & VBCrLf
    strSQL = strSQL & "WHERE" & VBCrLf
    strSQL = strSQL & "  DESCRIPTION LIKE '%10%'" & VBCrLf
    strSQL = strSQL & "ORDER BY" & VBCrLf
    strSQL = strSQL & "  ID"
 
    'Add a new worksheet to the new workbook, add after the last sheet
    ActiveWorkbook.Sheets.Add
    ActiveWorkbook.ActiveSheet.Name = "JustATest"
        
    snpData.Open strSQL, dbVMFG
        
    If snpData.State = 1 Then
        'Slow Method------------------------------------
        lngRow = 0
        'Header Row
        For i = 0 To snpData.Fields.Count – 1
            lngRow = lngRow + 1
            ActiveSheet.Cells(lngRow, i + 1).Value = snpData.Fields(i).Name
            ActiveSheet.Cells(lngRow, i + 1).Font.Bold = True
        Next i
 
        'Detail Rows
        Do While Not snpData.EOF
            lngRow = lngRow + 1
            For i = 0 To snpData.Fields.Count - 1
                ActiveSheet.Cells(lngRow, i + 1).Value = snpData.Fields(i)
            Next i
 
            snpData.MoveNext
        Loop
        'End Slow Method------------------------------------
 
        'Fast Method----------------------------------------
        'Do not use this and the slow method!
        For i = 0 To snpData.Fields.Count - 1
            ActiveSheet.Cells(1, i + 1).Value = snpData.Fields(i).Name
        Next i
        ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, snpData.Fields.Count)).Font.Bold = True
    
        ActiveSheet.Range("A2").CopyFromRecordset snpData
            
        'Auto-fit up to 26 columns
        ActiveSheet.Columns("A:" & Chr(64 + snpData.Fields.Count)).AutoFit
        'End Fast Method----------------------------------------
 
        snpData.Close
    End If
End If







Follow

Get every new post delivered to your Inbox.

Join 139 other followers