Word VBA, Save Table as JPEG

by azurous in Automation

In this article I will explain how you save a word table as a JPEG using VBA for word.

Unless if you are willing to using windows API functions, I have yet to find a direct method for doing this in VBA for word. The method I will be using in this article will follow these steps:

  • Automate an Excel application
  • Copy the table from word to Excel
  • Use the method explained in the article Excel VBA, Save Range/Cells as JPEG to save the tables data as a JPEG image.
–

Contents

Step 1, Automating Excel:

The first step would be to automate an Excel application. I’ve covered this topic in the article below:

The code below will open an empty Excel workbook:

Sub main2()
Dim objExcel As Object
Dim objWorkbook As Object

'create new application
Set objExcel = CreateObject("Excel.Application")
'make it visible
objExcel.Visible = True
'add a empty workbook
Set objWorkbook = objExcel.Workbooks.Add
End Sub

Result:

Excel, Empty Application

–

Copying Table Data to Excel:

The code below will copy the data from the table in the word document to the excel workbook:

'copies the table to the excel workbook
Tables.Item(1).Select
Selection.Copy
objWorkbook.sheets(1).Range("A1").Select
objWorkbook.ActiveSheet.Paste
'adjusts column width
For i = 1 To Tables.Item(1).Columns.Count
    objWorkbook.sheets(1).Columns(i).ColumnWidth = _
        8.43 / 48 * (Tables.Item(1).Columns.Item(i).Cells(1).Width)
Next i

Word Table:

Word, Table
Result:

Result
The lines below select the table and copy it:

Tables.Item(1).Select
Selection.Copy

The lines below paste the table in the excel workbook:

objWorkbook.sheets(1).Range("A1").Select
objWorkbook.ActiveSheet.Paste

The lines below adjust the width of the columns in the excel workbook to match those of the word table:

'adjusts column width
For i = 1 To Tables.Item(1).Columns.Count
    objWorkbook.sheets(1).Columns(i).ColumnWidth = _
        8.43 / 48 * (Tables.Item(1).Columns.Item(i).Cells(1).Width)
Next i

–

Excel Range to JPEG:

In the article below I’ve explained how can export a range of data in Excel as a JPEG image:

Based on what was explained in that article we can use the code below to create a JPEG image from the cells in the excel workbook. The image will be saved in the directory “D:StuffBusinessTemp”. You can change this to another location:

Dim intCount As Integer
Dim objPic As Object
Dim objChart As Object
Dim intRows As Integer
Dim intColumns As Integer
'copy the range as an image
intRows = Tables.Item(1).rows.Count
intColumns = Tables.Item(1).columns.Count


Call objWorkbook.Sheets(1).Range( _
    objWorkbook.Sheets(1).Cells(1, 1), _
    objWorkbook.Sheets(1).Cells(intRows _
    + 1, intColumns + 1)).CopyPicture( _
    xlScreen, xlPicture)

'remove all previous shapes in sheet2
intCount = objWorkbook.Sheets(2).Shapes.Count
For i = 1 To intCount
    objWorkbook.Sheets(2).Shapes.Item(1).Delete
Next i
'create an empty chart in sheet2
objWorkbook.Sheets(2).Shapes.AddChart
'activate sheet2
objWorkbook.Sheets(2).Activate
'select the shape in sheet2
objWorkbook.Sheets(2).Shapes.Item(1).Select
Set objChart = objExcel.ActiveChart
'paste the range into the chart

objWorkbook.Sheets(2).Shapes.Item(1 _
    ).Line.Visible = msoFalse
objWorkbook.Sheets(2).Shapes.Item(1 _
    ).Width = objWorkbook.Sheets(1 _
    ).Range(objWorkbook.Sheets(1).Cells(1, 1), _
    objWorkbook.Sheets(1).Cells(intRows _
    + 1, intColumns + 1)).Width
objWorkbook.Sheets(2).Shapes.Item(1 _
    ).Height = objWorkbook.Sheets(1 _
    ).Range(objWorkbook.Sheets(1).Cells(1, 1), _
    objWorkbook.Sheets(1).Cells(intRows _
    + 1, intColumns + 1)).Height
objChart.Paste
'save the chart as a JPEG
objChart.Export ("D:StuffBusinessTempExample.Jpeg")

The code above was explained in the article Excel VBA, Save Range/Cells as JPEG. Since we are using automation some changes have been made to accommodate for the late binding:

1-

Sheet1

Sheet2

Was replaced with:

objWorkbook.sheets (1)

objWorkbook.sheets (2)

2-

Sheet1.Range("A1:E12")

Was replaced with:

objWorkbook.Sheets(1 _
    ).Range(objWorkbook.Sheets(1).Cells(1, 1), _
    objWorkbook.Sheets(1).Cells(intRows _
    + 1, intColumns + 1)).Width

For more information about automation please see the link below:

–

Complete Code:

Below you can see the complete code:

Sub Example()
Dim objExcel As Object
Dim objWorkbook As Object
Dim i As Integer
Dim intCount As Integer
Dim objPic As Object
Dim objChart As Object
Dim intRows As Integer
Dim intColumns As Integer
'''
'Part 1
'create new application
Set objExcel = CreateObject("Excel.Application")
'make it visible
objExcel.Visible = True
'add a empty workbook
Set objWorkbook = objExcel.Workbooks.Add


'''
'Part 2
'copies the table to the excel workbook
Tables.Item(1).Select
Selection.Copy
objWorkbook.Sheets(1).Range("A1").Select
objWorkbook.ActiveSheet.Paste
'adjusts column width
For i = 1 To Tables.Item(1).columns.Count
    objWorkbook.Sheets(1).columns(i).ColumnWidth = _
        8.43 / 48 * (Tables.Item(1).columns.Item(i).Cells(1).Width)
Next i

'''
'Part 3
'copy the range as an image
intRows = Tables.Item(1).rows.Count
intColumns = Tables.Item(1).columns.Count

Call objWorkbook.Sheets(1).Range( _
    objWorkbook.Sheets(1).Cells(1, 1), _
    objWorkbook.Sheets(1).Cells(intRows _
    + 1, intColumns + 1)).CopyPicture( _
    xlScreen, xlPicture)

'remove all previous shapes in sheet2
intCount = objWorkbook.Sheets(2).Shapes.Count
For i = 1 To intCount
    objWorkbook.Sheets(2).Shapes.Item(1).Delete
Next i
'create an empty chart in sheet2
objWorkbook.Sheets(2).Shapes.AddChart
'activate sheet2
objWorkbook.Sheets(2).Activate
'select the shape in sheet2
objWorkbook.Sheets(2).Shapes.Item(1).Select
Set objChart = objExcel.ActiveChart
'paste the range into the chart

objWorkbook.Sheets(2).Shapes.Item(1 _
    ).Line.Visible = msoFalse
objWorkbook.Sheets(2).Shapes.Item(1 _
    ).Width = objWorkbook.Sheets(1 _
    ).Range(objWorkbook.Sheets(1).Cells(1, 1), _
    objWorkbook.Sheets(1).Cells(intRows _
    + 1, intColumns + 1)).Width
objWorkbook.Sheets(2).Shapes.Item(1 _
    ).Height = objWorkbook.Sheets(1 _
    ).Range(objWorkbook.Sheets(1).Cells(1, 1), _
    objWorkbook.Sheets(1).Cells(intRows _
    + 1, intColumns + 1)).Height
objChart.Paste
'save the chart as a JPEG
objChart.Export ("D:StuffBusinessTempExample.Jpeg")

End Sub

Result:

Example

–

Multiple Tables:

If there are multiple tables in the document you could use the code below:

Sub Example2()
Dim objExcel As Object
Dim objWorkbook As Object
Dim i As Integer
Dim j As Integer
Dim intCount As Integer
Dim objPic As Object
Dim objChart As Object
Dim intRows As Integer
Dim intColumns As Integer
'''
'Part 1
'create new application
Set objExcel = CreateObject("Excel.Application")
'make it visible
objExcel.Visible = True
'add a empty workbook
Set objWorkbook = objExcel.Workbooks.Add


'''
'Part 2
'copies the table to the excel workbook
For j = 1 To Tables.Count

    Tables.Item(j).Select
    Selection.Copy
    objWorkbook.Sheets(1).Cells.Clear
    objWorkbook.Sheets(1).Activate
    objWorkbook.Sheets(1).Range("A1").Select
    objWorkbook.ActiveSheet.Paste
    'adjusts column width
    For i = 1 To Tables.Item(1).columns.Count
        objWorkbook.Sheets(1).columns(i).ColumnWidth = _
           8.43 / 48 * (Tables.Item(1).columns.Item(i).Cells(1).Width)
    Next i
     
    '''
    'Part 3
    'copy the range as an image
    intRows = Tables.Item(j).rows.Count
    intColumns = Tables.Item(j).columns.Count
     
    Call objWorkbook.Sheets(1).Range( _
        objWorkbook.Sheets(1).Cells(1, 1), _
        objWorkbook.Sheets(1).Cells(intRows _
        + 1, intColumns + 1)).CopyPicture( _
        xlScreen, xlPicture)
     
    'remove all previous shapes in sheet2
    intCount = objWorkbook.Sheets(2).Shapes.Count
    For i = 1 To intCount
        objWorkbook.Sheets(2).Shapes.Item(1).Delete
    Next i
    'create an empty chart in sheet2
    objWorkbook.Sheets(2).Shapes.AddChart
    'activate sheet2
    objWorkbook.Sheets(2).Activate
    'select the shape in sheet2
    objWorkbook.Sheets(2).Shapes.Item(1).Select
    Set objChart = objExcel.ActiveChart
    'paste the range into the chart
     
    objWorkbook.Sheets(2).Shapes.Item(1 _
        ).Line.Visible = msoFalse
    objWorkbook.Sheets(2).Shapes.Item(1 _
        ).Width = objWorkbook.Sheets(1 _
        ).Range(objWorkbook.Sheets(1).Cells(1, 1), _
        objWorkbook.Sheets(1).Cells(intRows _
        + 1, intColumns + 1)).Width
    objWorkbook.Sheets(2).Shapes.Item(1 _
        ).Height = objWorkbook.Sheets(1 _
        ).Range(objWorkbook.Sheets(1).Cells(1, 1), _
        objWorkbook.Sheets(1).Cells(intRows _
        + 1, intColumns + 1)).Height
    objChart.Paste
    'save the chart as a JPEG
    objChart.Export ("D:StuffBusinessTempExample" & j & ".Jpeg")
Next j
End Sub

Assume we have the following tables in the word document:

Word, Tables
Result:

2 Images in the selected folder:

Resulting, Tables, Word, VBA

You can download the file and code related to this article from the link below:

See also:

If you need assistance with your code, or you are looking for a VBA programmer to hire feel free to contact me. Also please visit my website  www.software-solutions-online.com

Tagged with: , , ,

Leave a Reply

Your email address will not be published. Required fields are marked *