Word VBA, Save Table as JPEG
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:
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:
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:
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:
2 Images in the selected folder:
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