Excel&PowerPoint批量制作会议桌牌

无论是组织培训,安排会议,还是举办宴会,制作桌牌都是必备事项之一。看似简单的桌牌,在繁忙的准备工作中却会占用很多宝贵的时间和精力,尤其当参会人数众多时尤甚。今天我们就一起研究一下,快速批量制作桌牌的方法。(本教程面向对VBA多少有些了解的用户,步骤我会写的尽量详细,如果您不知道如何使用VBA代码,也可以直接到最后下载示例文件,在基础上修改使用。)

首先,说起批量制作固定格式的文件,熟悉Office的老司机通常会立即想到Word的邮件合并功能。的确,很长时间以来Hsiang也是使用邮件合并功能来制作桌牌的。不过,一个缺憾也是始终无法解决的,那就是Word中文本无法方便地旋转,如果要制作下图这种“标准”的双面桌牌,就不得不在同一张纸上打印两次。2016-01-05_203143.png

为了解决这个问题,我们可以使用PowerPoint插入文本框的方式来制作,这样一来,文字可以方便的旋转倒置了,但是却无法批量制作,只能手工一张一张插入幻灯片。如何才能鱼和熊掌兼得?我们来看下面一种解决方案:

基本的思路是:将名单存储在Excel表格中,通过VBA操作PowerPoint对象,把姓名逐个插入准备好的PowerPoint模板中,完成批量制作。

步骤:

  1. 首先,我们根据实际需求,制作出PowerPoint母版。在本例中,我希望制作如之前图片样式的A4尺寸四折双面桌牌,需要现在PowerPoint中将幻灯片大小设置为A4纸大小2016-01-05_204825.png

    然后,在在需要打印文字的地方插入文本框,输入文字,调整到合适位置。如果需要加入背景图案或logo,注意要插入到幻灯片母版中,不要在幻灯片中直接插入。这样,桌牌的模板就制作好了。注意,这步的目的在于制作可以复用的幻灯片母版(大小、图案等),以及下一步获取文字位置坐标。

  2. 确定桌牌模板后,我们需要获取关键的参数:插入文字的位置坐标。在PowerPoint中查看文本框的属性会发现位置的单位是厘米,无法直接获得VBA程序能读懂的坐标信息。所以我们需要工具来查看每个文本框的位置坐标并记录下来备用。详见PowerPoint获取图形或文本框的位置参数

  1. 第三步,根据实际需要准备人员名单。本例中,在Excel中制作如下图的人员名单:
    2016-01-05_214619.png

  2. 根据模板,编辑相应的VBA代码,使用VBA制作桌牌。将以下代码写入Excel文件中:

    先奉上完整代码:

     Sub 批量桌牌()
     Dim MyFile As String
     Dim MyRange As Range
     Dim Mytemx As Integer
     Dim MyApp As Object
     Dim Myppt As Object
     Dim MySlide As Object
     Dim MyShape As Object
     Dim Initdir As String
     Dim Myfd As FileDialog
     Const ppLayoutBlank = 12
    
     Initdir = ThisWorkbook.Path & "\"
     Set Myfd = Application.FileDialog(msoFileDialogFilePicker)
         With Myfd
             .AllowMultiSelect = False
             .Filters.Clear
             .Filters.Add "PPTX文件", "*.ppt; *.pptx", 1
             .InitialFileName = Initdir
             .Title = "选择一个PowerPoint文件"
             .Show
             
             If .SelectedItems.Count < 1 Then
                  MyFile = ""
                  MsgBox "没有选择文件"
                  Exit Sub
             End If
             
             MyFile = .SelectedItems(1)
         End With
         
     On Error Resume Next
     Set MyApp = GetObject(, "PowerPoint.Application")
         If Err.Number <> 0 Then
             Set MyApp = CreateObject("PowerPoint.Application")
         End If
     Err.Clear
     On Error GoTo 0
    
     Set Myppt = MyApp.Presentations.Open(MyFile)
    
     AppActivate Application.Caption
    
     response = MsgBox("是否删除ppt原有内容?", vbYesNoCancel, "警告")
     If response = vbYes Then
         For k = Myppt.Slides.Count To 1 Step -1
             Myppt.Slides(k).Delete
         Next
     Else
         If response = vbCancel Then
             Exit Sub
         End If
     End If
    
     Mytemx = ActiveSheet.Range("a1").End(xlDown).Row
     Set MyRange = ActiveSheet.Range("a2:a" & Mytemx)
     i = 1
     For Each temr In MyRange
         Set MySlide = Myppt.Slides.Add(Myppt.Slides.Count + 1, ppLayoutBlank)     '添加新的幻灯片
         
         Set MyShape = MySlide.Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
         Left:=197, Top:=260, Width:=146, Height:=86)      '此处写入刚才记录的位置坐标
         MyShape.Rotation = 180 '旋转180度
         With MyShape.TextFrame
             .TextRange.Text = temr       '文本赋值
             .TextRange.Font.NameFarEast = "宋体"
             .TextRange.Font.Bold = False     '文本加粗
             .TextRange.Font.Shadow = False   '文本阴影
             .TextRange.Font.Size = 60        '文本字体
             .TextRange.Font.Color.RGB = RGB(0, 0, 0)    '文本颜色
             .HorizontalAnchor = msoAnchorCenter         '文本水平居中
             .VerticalAnchor = msoAnchorTop              '文本垂直居中
         End With
         MyShape.Left = MySlide.CustomLayout.Width / 2 - MyShape.Width / 2 '文本框居中
             
         Set MyShape = MySlide.Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
         Left:=197, Top:=214, Width:=145, Height:=49)      '此处写入刚才记录的位置坐标
         MyShape.Rotation = 180 '旋转180度
         With MyShape.TextFrame
             .TextRange.Text = temr.Offset(0, 1) & " " & temr.Offset(0, 2) '文本赋值
             .TextRange.Font.Name = "华文楷体"
             .TextRange.Font.Bold = True     '文本加粗
             .TextRange.Font.Shadow = False  '文本阴影
             .TextRange.Font.Size = 32       '文本字体
             .TextRange.Font.Color.RGB = RGB(0, 0, 0)    '文本颜色
             .HorizontalAnchor = msoAnchorCenter         '文本水平居中
             .VerticalAnchor = msoAnchorTop              '文本垂直居中
         End With
         MyShape.Left = MySlide.CustomLayout.Width / 2 - MyShape.Width / 2     '文本框居中
             
         Set MyShape = MySlide.Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
             Left:=196, Top:=433, Width:=146, Height:=86)      '此处写入刚才记录的位置坐标
         With MyShape.TextFrame
             .TextRange.Text = temr '文本赋值
             .TextRange.Font.NameFarEast = "宋体"
             .TextRange.Font.Bold = False     '文本加粗
             .TextRange.Font.Shadow = False   '文本阴影
             .TextRange.Font.Size = 60        '文本字体
             .TextRange.Font.Color.RGB = RGB(0, 0, 0)    '文本颜色
             .HorizontalAnchor = msoAnchorCenter         '文本水平居中
             .VerticalAnchor = msoAnchorTop              '文本垂直居中
         End With
         MyShape.Left = MySlide.CustomLayout.Width / 2 - MyShape.Width / 2 '文本框居中
             
         Set MyShape = MySlide.Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
             Left:=198, Top:=516, Width:=145, Height:=49)      '此处写入刚才记录的位置坐标
         With MyShape.TextFrame
             .TextRange.Text = temr.Offset(0, 1) & " " & temr.Offset(0, 2) '文本赋值
             .TextRange.Font.Name = "华文楷体"
             .TextRange.Font.Bold = True    '文本加粗
             .TextRange.Font.Shadow = False '文本阴影
             .TextRange.Font.Size = 32      '文本字体
             .TextRange.Font.Color.RGB = RGB(0, 0, 0)    '文本颜色
             .HorizontalAnchor = msoAnchorCenter         '文本水平居中
             .VerticalAnchor = msoAnchorTop              '文本垂直居中
         End With
         MyShape.Left = MySlide.CustomLayout.Width / 2 - MyShape.Width / 2     '文本框居中
         
         Next temr
    
     AppActivate Application.Caption
     MsgBox "已完成"
     MyApp.Activate
     End Sub
    

    这里解释一下执行插入文字操作的部分:

    Set MyShape = MySlide.Shapes.AddLabel(Orientation:=msoTextOrientationHorizontal, _
        Left:=197, Top:=260, Width:=146, Height:=86)      '此处写入刚才记录的位置坐标
        MyShape.Rotation = 180 '旋转180度
        With MyShape.TextFrame
            .TextRange.Text = temr       '文本赋值
            .TextRange.Font.NameFarEast = "宋体"
            .TextRange.Font.Bold = False     '文本加粗
            .TextRange.Font.Shadow = False   '文本阴影
            .TextRange.Font.Size = 60        '文本字体
            .TextRange.Font.Color.RGB = RGB(0, 0, 0)    '文本颜色
            .HorizontalAnchor = msoAnchorCenter         '文本水平居中http://teaink.com/adminhyx/write-post.php?cid=120###
            .VerticalAnchor = msoAnchorTop              '文本垂直居中
        End With
        MyShape.Left = MySlide.CustomLayout.Width / 2 - MyShape.Width / 2 '文本框居中
    

    在示例中有4个这样的代码块,分别在每张新建幻灯片中插入四个文本框以及相应文字。第二步中所得到的位置坐标即是用来确定每个文本框所在的位置。同时文本样式,字体,字号等也是在这个块中进行设置。

    所有参数设置好后,保存并在Excel中插入链接到此程序的按钮,一套完整的桌牌生成工具就完成了。只需轻点鼠标,喝杯茶放松一下,桌牌便制作完成了。(同样的方法还适用于制作奖状和证书。)

    示例文件下载:
    批量制作桌牌v1.1.xlsm
    桌牌模板.pptx



知识共享许可协议
除非注明,本博客文章均为原创
并采用知识共享署名-非商业性使用 4.0 国际许可协议进行许可。转载请以URL链接形式标注源地址。

标签: excel, powerpoint, 桌牌, vba, 邮件合并

添加新评论