excel学习库

工程项目图纸往往需要插表阐述图纸内容。实际操作中往往通过复制Excel表格区域，然后粘贴到作图软件的图幅中。当面对大量图幅时，复制粘贴的方式低效率、易出错的弊端就会显现。本文将介绍VBA实现的Excel批量导出图片工具的具体实现。

一、开启Excel开发工具

”

图1 Excel开启开发工具的设置对话框截图

菜单。

图2 开发工具子菜单

二、创建窗体

从开发工具菜单的子菜单项“Visual Basic”进入“VBA工程”页面，见图3。

图3 VBA工程页面截图

在VBA工程页面左侧的工程结构的窗体节点，右键插入窗体。并按图4设计窗体。

图4 窗体设计图

三、编写代码

设计窗体右键查看代码，将下文所列代码粘贴至相应的代码块中。注意，窗体中的控件命名，它将影响代码中的函数名。

'Excel 2010 以及之后的版本使用如下声明代码

Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)

Dim work_sheet As String '工作表

Private Sub bt_export_images_Click()

If Not IsReady() Then

Exit Sub

End If

Call ExportImage

End Sub

Private Sub bt_export_path_Click()

'获取导出图片的目录

With Application.FileDialog(msoFileDialogFolderPicker)

.InitialFileName = Me.tb_export_path.Text

.title = "请选择导出图片的目录"

If .Show Then

Me.tb_export_path.Text = .SelectedItems(1)

End If

End With

End Sub

Private Sub bt_image_page_col_Click()

'选择图片页面标记列

Dim image_page_col As Range

Dim message, title As String

Dim title_range As Range '标题区域

If Me.tb_title_range.Text = "" Then

MsgBox "请先选择填入标题区域"

Exit Sub

End If

Set title_range = Range(Me.tb_title_range.Text) '标题区域

message = "请选择图片页面标记列"

title = "选择页面标记列"

On Error GoTo Error_Handler:

Set image_page_col = Application.InputBox(prompt:=message, title:=title, Type:=8)

If image_page_col.Columns.Count > 1 Then

MsgBox "页面标记列只能包含1列或1个单元格"

Exit Sub

End If

title_range_start_col = title_range.Column

title_range_end_col = title_range_start_col + title_range.Columns.Count - 1

my_col = image_page_col.Column

If my_col <> title_range_end_col Then

MsgBox "页面分组列应在标题列区域内，且必须位于标题区域的最后1列"

Exit Sub

End If

Me.tb_image_page_col.Text = image_page_col.Address

Exit Sub

Error_Handler:

Exit Sub

End Sub

Private Sub bt_title_range_Click()

'选择标题区域

Dim title_range As Range

Dim message, title As String

message = "请选择导出图片表格的标题区域"

title = "选择标题区域"

On Error GoTo Error_Handler:

Set title_range = Application.InputBox(prompt:=message, title:=title, Type:=8)

If title_range.Count < 3 Then

MsgBox "标题区域不应小于3个单元格"

Exit Sub

End If

work_sheet = ActiveSheet.Name '设定工作表

Me.tb_title_range.Text = title_range.Address

Exit Sub

Error_Handler:

Exit Sub

End Sub

Private Function IsReady()

'检查数据有效性

Dim textboxes As New Collection

textboxes.Add (Me.tb_title_range)

textboxes.Add (Me.tb_image_page_col)

textboxes.Add (Me.tb_export_path)

For Each tb In textboxes

If tb = "" Then

MsgBox "请补充完整数据"

IsReady = False

Exit Function

End If

Next

IsReady = True

End Function

Private Sub ExportImage()

'导出图片

Dim title_range As Range '标题区域

Dim title_lu_cell As Range '标题左上角单元格

Dim content_lu_cell As Range '内容左上角单元格

Dim content_rd_cell As Range '内容右下角单元格

Dim image_page_col_top_cell As Range '图片页面标签列顶部单元格

Dim image_page_col_end_cell As Range '图片页面标签列底部单元格

Dim image_page_col As Range '输入的图片页面列

Dim new_picure As Shape '图片

Dim range_for_save As Range '被用于保存的图片区域

Set title_range = Range(Me.tb_title_range.Text) '标题区域

Set title_lu_cell = title_range.Item(1) '标题左上角单元格

title_range_row_num = title_range.Rows.Count ' 标题行数

title_range_col_num = title_range.Columns.Count '标题列数

Set image_page_col = Range(Me.tb_image_page_col.Text) '输入的图片页面列

'图片页面标签列顶部单元格

Set image_page_col_top_cell = image_page_col.Item(1).Offset(image_page_col.Row - title_lu_cell.Row + title_range_row_num, 0)

'图片页面标签列底部单元格

Set image_page_col_end_cell = image_page_col_top_cell.End(xlDown)

'内容左上角单元格

Set content_lu_cell = Cells(title_lu_cell.Row + title_range_row_num, title_lu_cell.Column)

'内容右下角单元格,为避免合并单元格导致的偏移操作结果不可预测，偏移操作的起始单元格都不应存在合并单元格的可能

Set content_rd_cell = Cells(image_page_col_end_cell.Row, title_lu_cell.Column + title_range_col_num - 1)

'内容第一行行号

content_first_row = content_lu_cell.Row

'排序

ActiveWorkbook.Worksheets(work_sheet).Sort.SortFields.Clear

'设定排序字段

ActiveWorkbook.Worksheets(work_sheet).Sort.SortFields.Add Key:=Range(image_page_col_top_cell _

, image_page_col_end_cell), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

With ActiveWorkbook.Worksheets(work_sheet).Sort

.SetRange Range(content_lu_cell, content_rd_cell)

.Header = xlNo

.MatchCase = False

.Orientation = xlTopToBottom

.SortMethod = xlPinYin

.Apply

End With

'隐藏图片页面标签列

'image_page_col.EntireColumn.Hidden = True

front_row_page_group_flag = "" '前一行页面分组标签

front_row_image_page_flag = "" '前一行照片页面标签

content_fist_row = content_lu_cell.Row '表格内容区域第一行行号

current_row_num = content_lu_cell.Row - 1 '初始化当前所处行号

file_path = Me.tb_export_path.Text '文件保存目录

i = 0

has_passed_firt_content_row = False '已过第一行内容数据标记

'循环导出

Do While current_row_num <= content_rd_cell.Row

current_row_num = current_row_num + 1

current_image_page_flag = image_page_col_top_cell.Offset(current_row_num - content_fist_row, 0).Text '当前照片页面标签

front_row_image_page_flag = image_page_col_top_cell.Offset(current_row_num - content_fist_row - 1, 0).Text '上一行照片页面标签

If current_image_page_flag <> front_row_image_page_flag Then

'新图片第一行

If has_passed_firt_content_row Then

'导出图片

file_name = file_path & "/" & front_row_image_page_flag & ".jpg"

Set range_for_save = Range(title_lu_cell, content_lu_cell.Offset(current_row_num - content_first_row - 1, content_rd_cell.Column - title_lu_cell.Column - 1))

range_for_save.CopyPicture

With ActiveSheet.ChartObjects.Add(0, 0, range_for_save.Width, range_for_save.Height).Chart

.Parent.Select

.Paste

.Export file_name

.Parent.Delete

End With

'隐藏已导出图片的数据行

Range(content_lu_cell, content_lu_cell.Offset(current_row_num - content_first_row - 1, 0)).EntireRow.Hidden = True

Set range_for_save = Nothing

End If

End If

i = i + 1

has_passed_firt_content_row = True

'暂停100毫秒

Sleep 100

Loop

'显示图片页面标签列

image_page_col.EntireColumn.Hidden = False

'显示表格内容全部隐藏的行

Range(content_lu_cell, content_rd_cell).EntireRow.Hidden = False

MsgBox "完成导出图片.."

End Sub

Private Sub UserForm_Click()

End Sub

四、使用方法

在输出的图片中，实际的标题区域不包括分页列。分页列用于确定各分页所包含的表格内容，以及输出图片的名称。

图5 批量导出图片窗体工具使用截图

图6 输出效果

五、联系小编

您可以按上文介绍的方法完成工具创建，也可以私信联系小编索取窗体文件，直接通过导入窗体引入该功能。

“数图”（别名“数图本”）是小编开发的一款通用田野调查数据采集软件，适用于林业调查规划、生态科学考察、动植物保护、资源调查、市场调研、户外运动等多种场景。数据采集内容完全自定义，真正做到“随时设计，即刻使用”。欢迎下载使用。