VBA实现Excel批量导出图片——附源码

风声之家 2022-02-17

展开全文

原创数图数图分析 2022-02-03 22:37

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

一、开启Excel开发工具

本文操作环境Microsoft Office Excel 2016学生版。通过菜单 “文件 > 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 WithEnd 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 SubError_Handler:    Exit SubEnd 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 SubError_Handler:    Exit Sub    End Sub
Private Sub Label1_Click()
End Sub
Private Sub Label2_Click()
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 = TrueEnd 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