Extract the First 4400 Images from Excel 2003 (and Above) and Transfer to a Database Table

28 12 2009

December 28, 2009

This code sample is an Excel 2003/2007 macro that extracts all of the named toolbar button pictures from Excel 2003/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 EXCEL2003_TOOLBAR_PICTURES (
  PICTURE_NAME VARCHAR2(60),
  PICTURE_SIZE NUMBER,
  PICTURE BLOB,
  PRIMARY KEY(PICTURE_NAME));

See the instructions in the previous blog article to enable macro support in Excel 2007 and add a reference to the ActiveX Data Objects in Excel 2003 and above.

The Excel macro code follows:

Private Sub ExtractAllImages2003()
    'Adapted from an example by John Walkenbach
    '    http://www.dailydoseofexcel.com/archives/2006/11/16/displaying-commandbar-faceid-images/
    'See also http://support.microsoft.com/kb/286460
    Dim i As Integer
    Dim intResult As Integer
    Dim intFileNum2 As Integer
    Dim lngNumPics As Long
    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 tbNewToolbar As CommandBar
    Dim tbcNewControl As CommandBarButton
    Dim picPicture As stdole.IPictureDisp
    Dim picMask As stdole.IPictureDisp
    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("BuiltInImages2003").Delete

    Sheets.Add
    ActiveSheet.Name = "BuiltInImages2003"

    'Delete existing TempFaceIds toolbar if it exists
    Application.CommandBars("TempFaceIds").Delete

    'Add an empty toolbar
    Set tbNewToolbar = Application.CommandBars.Add(Name:="TempFaceIds")

    'Create an object to act as a command bar control
    Set tbcNewControl = tbNewToolbar.Controls.Add(Type:=msoControlButton)

    Application.DisplayAlerts = True

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

    Err = 0

    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 EXCEL2003_TOOLBAR_PICTURES (
    '  PICTURE_NAME VARCHAR2(60),
    '  PICTURE_SIZE NUMBER,
    '  PICTURE BLOB,
    '  PRIMARY KEY(PICTURE_NAME));

    If Err = 0 Then
        'Remove pictures that were previously brought in
        strSQL = "DELETE FROM EXCEL2003_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 & "  EXCEL2003_TOOLBAR_PICTURES"
        dynData.Open strSQL, dbDatabase, adOpenKeyset, adLockOptimistic, adCmdText

        For i = 1 To 4400  'Maximum in Excel 2003 is around 10033
            'Set the picture on the command bar control to picture number i
            tbcNewControl.FaceId = i

            'Transfer the pictures from the command bar control to local variables
            Set picPicture = tbcNewControl.Picture
            Set picMask = tbcNewControl.Mask

            'Save the pictures to disk
            strName = "FaceID " & Format(i, "0000") & ".bmp"
            Application.StatusBar = strName
            stdole.SavePicture picPicture, "C:\ExcelBuiltInImages2003\temp.bmp"

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

            'Read the picture into the table
            intFileNum2 = FreeFile
            Open "C:\ExcelBuiltInImages2003\temp.bmp" For Binary As #intFileNum2
            'Prepare a variable of byte data type to hold the picture read from disk
            ReDim bytPicture(FileLen("C:\ExcelBuiltInImages2003\temp.bmp"))
            Get #intFileNum2, , bytPicture
            Close #intFileNum2

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

            'Save the mask picture for the toolbar button
            stdole.SavePicture picMask, "C:\ExcelBuiltInImages2003\temp.bmp"
            strName = "FaceID " & Format(i, "0000") & " Mask.bmp"

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

            'Read the picture into the table
            intFileNum2 = FreeFile
            Open "C:\ExcelBuiltInImages2003\temp.bmp" For Binary As #intFileNum2
            'Prepare a variable of byte data type to hold the picture read from disk
            ReDim bytPicture(FileLen("C:\ExcelBuiltInImages2003\temp.bmp"))
            Get #intFileNum2, , bytPicture
            Close #intFileNum2

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

            'Free the memory ffrom the local variables
            Set picPicture = Nothing
            Set picMask = Nothing

            'Allow Excel to process events every 160 pictures
            If i Mod 160 = 0 Then
                Application.ScreenUpdating = True
                DoEvents
                Application.ScreenUpdating = False
            End If
        Next i

        dbDatabase.CommitTrans
        dynData.Close

        'Delete the picture from the folder
        Kill "C:\ExcelBuiltInImages2003\temp.bmp"

        '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 & "  EXCEL2003_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
                intFileNum2 = FreeFile
                ReDim bytPicture(snpData("picture_size"))
                bytPicture = snpData("picture")

                Open "C:\ExcelBuiltInImages2003\" & 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 40) * 18
                sglY = Int((i - 1) / 40) * 18

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

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

                snpData.MoveNext
            Loop
            snpData.Close
        End If
    End If

    Application.CommandBars("TempFaceIds").Delete

    Application.ScreenUpdating = True
    Application.StatusBar = ""
    dbDatabase.Close

    'Clean up
    Set snpData = Nothing
    Set dynData = Nothing
    Set dbDatabase = 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 and the mask for the temp.bmp picture that will allow creating a semi-transparent button image.  Once all of the pictures are stored in the database, a query is run to retrieve each of the pictures, create a file in the ExcelBuiltInImages2003 folder for that picture, and then display the picture in Excel.  The screen is refreshed after every 160 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, so the icons are extracted at that size.  The picture filenames are written to 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:


Actions

Information

3 responses

7 09 2011
Jason B

I needed to do something more simple: extract all the images from a custom toolbar I created in Excel 2003. I adapted a few lines of code from the above example and am posting it here in case someone else runs across this post with similar needs to mine.

Private Sub ExtractImagesFromCustomToolbar()

    Dim i As Integer
    Dim picPicture As stdole.IPictureDisp
    Dim picMask As stdole.IPictureDisp

    On Error Resume Next

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

        For i = 1 To 32  'Must set number of controls manually (count the items in your custom toolbar)

            'Transfer the pictures from the command bar control to local variables
            'If you don't know the number associated with your custom toolbar, run the CommandBarNames() subroutine below
            
            Set picPicture = Application.CommandBars(126).Controls(i).Picture
            Set picMask = Application.CommandBars(126).Controls(i).Mask

            'Save the pictures to disk
            stdole.SavePicture picPicture, "C:\ExcelBuiltInImages2003\" & i & "-Pic.bmp"

            'Save the mask picture for the toolbar button
            stdole.SavePicture picMask, "C:\ExcelBuiltInImages2003\" & i & "-Mask.bmp"

            'Free the memory from the local variables
            Set picPicture = Nothing
            Set picMask = Nothing

        Next i

End Sub


Sub CommandBarNames()
'Run this to identify the number associated with your custom toolbar(s)
'After running it, manually review the CommandBarNames spreadsheet to identify the numbers

On Error GoTo Outta

For i = 1 To 200

Sheets("CommandBarNames").Cells(i, 1) = Application.CommandBars(i).Name
Sheets("CommandBarNames").Cells(i, 2) = i

Next i

Outta:

End Sub
7 09 2011
Jason B

Oops! Typo in the code above. All the directories need to be consistent.

Private Sub ExtractImagesFromCustomToolbar()

    Dim i As Integer
    Dim picPicture As stdole.IPictureDisp
    Dim picMask As stdole.IPictureDisp

    On Error Resume Next

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

        For i = 1 To 32  'Must set number of controls manually (count the items in your custom toolbar)

            'Transfer the pictures from the command bar control to local variables
            'If you don't know the number associated with your custom toolbar, run the CommandBarNames() subroutine below
            
            Set picPicture = Application.CommandBars(126).Controls(i).Picture
            Set picMask = Application.CommandBars(126).Controls(i).Mask

            'Save the pictures to disk
            stdole.SavePicture picPicture, "C:\Excel_2003_Toolbar_Images\" & i & "-Pic.bmp"

            'Save the mask picture for the toolbar button
            stdole.SavePicture picMask, "C:\Excel_2003_Toolbar_Images\" & i & "-Mask.bmp"

            'Free the memory from the local variables
            Set picPicture = Nothing
            Set picMask = Nothing

        Next i

End Sub


Sub CommandBarNames()
'Run this to identify the number associated with your custom toolbar(s)
'After running it, manually review the CommandBarNames spreadsheet to identify the numbers

On Error GoTo Outta

For i = 1 To 200

Sheets("CommandBarNames").Cells(i, 1) = Application.CommandBars(i).Name
Sheets("CommandBarNames").Cells(i, 2) = i

Next i

Outta:

End Sub
8 09 2011
Charles Hooper

Jason,

Thank you for sharing your modified version of this solution.

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: