桌签生成工具 - 公务员得来一个

讨论分享
1

这是分享到发现频道的一个 Windows 应用，叫做 桌签生成工具

%E5%B8%AD%E7%AD%BE%E7%A4%BA%E6%84%8F%E5%9B%BE1.png989×447 29 KB

用途简单，都见过电视里开会的时候，桌面上放的姓名栏么？一般是粉底黑字，这个工具就是用来生成那个名牌的东西。

然而在 Win10 中，无法运行，本来想发到小众的，但运行不能比较崩溃。谁有老版本的 Windows 来试试。不知道能不能改变背景色呢。

https://faxian.appinn.com/2339

经常开会，打印桌签是常事，也是小事。但即便有现成的模板，也需要手工一个个输入并打印，费时又费力。于是，想“偷懒”的人（我）打算编写一个小工具来代替人工。用法：输入与会人员名单，批量生成所有桌签到一个文档，放好纸，点“打印”按钮，打印机开始工作，你可以坐下来喝一口茶。希望此软件能帮使用者节省时间，提高效率，增一分惬意！

4 个赞
2

这个用office自带的vba可以实现的说

3

这个好用

4

这个东西还不错，不过在我们这都是有一个word模板，直接改直接打印出来，也很迅速。

5

雾草，这个好，我以前是用笨拙的PS动作做的。上次做了18个桌签，手指就崩溃了。
桌签麻烦不是人名，是尺寸啊，有些桌签壳子特别小，A4对折也塞不进去，需要手工测试字的相对位置，定好了位置再开打，打完再拿起裁纸刀裁切……还有的桌签正反2张纸是分开塞的，不能对折塞入……
后来发现，酒店里有这套服务的，订了会场就可以帮打。包袱甩给酒店了哈哈哈。

背景色没必要改，因为现在机关里是激光打印机的天下，以前想找个彩打机打红头都找不到……
需要打彩色背景的桌签的话，是专门买红纸、黄纸打的。

1 个赞
6

请问下载链接在吗？对我非常有帮助

7

该贴已过去8年，不会有更新了。

8

原先的还能使用吗？请分享一下，对我很有用

9

Win 10 用不了。

您可以考虑用 Word 做个模板备用。

10

好的，谢谢，

11 
'====================================================================
'                            使用说明:  
'制作 VBA 文件时, 请只保留一个Sub 用于执行,  其他过程请用 Function 关键字。
'Sub 过程名推荐用 用户ID_中文名称 的方式命名,避免代码冲突。
'VBA 文件请使用ANSI(简体中文GB2312)编码保存, 微软的VBA解释器不支持UTF-8这类编码,会导致中文乱码。
'不正确的代码可能导致word崩溃、文档丢失或损坏。
'请务必保证vba代码来源安全可靠，插件作者不承担vba文件造成的任何损失！
'分享 VBA 文件时，请尊重作者版权，注明来源以示感谢。
'====================================================================

'  原作者: 413191246se
'  源码地址: https://club.excelhome.net/thread-1649038-1-1.html
'  修改人: 小恐龙
'  使用方法:  这是一个桌签标牌制作代码,  新建word文档内输入参会人员姓名,每行一个姓名.运行本文件即可


Option Explicit    '强制声明变量是个好习惯, 可以提高代码速度,减少bug
Sub xkonglong_桌签标牌()
'标牌
    Dim c As Cell, i&, j&
    DataInit
    With ActiveDocument
        .PageSetup.Orientation = wdOrientLandscape
        ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitFullPage
        Selection.InsertColumnsRight
        .Tables(1).AutoFitBehavior (wdAutoFitWindow)
        j = .Tables(1).Rows.Count
        With .Tables(1)
            For i = 1 To j
                .Cell(i, 2).Range.Text = .Cell(i, 1).Range.Text
            Next i
        End With
        .Content.Find.Execute "^p", , , , , , , , , "", 2
        With .Tables(1).Range
            .Style = "普通表格"
            .Rows.HeightRule = wdRowHeightExactly
            .Rows.Height = CentimetersToPoints(14.6)
            .Cells.VerticalAlignment = wdCellAlignVerticalCenter
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
            With .Font
                .NameFarEast = "黑体"
                .Size = 72
                .Bold = True
            End With
            .Columns(1).Select
            .Orientation = wdTextOrientationDownward
            For Each c In .Columns(2).Cells
                c.Range.Orientation = wdTextOrientationUpward
            Next
        End With
    End With
    LastPound
    ActiveWindow.View.TableGridlines = True
    Selection.HomeKey 6
End Sub


Function DataInit()
    Dim c As Cell
    With ActiveDocument
        .Content.Find.Execute "^l", , , 0, , , , , , "^p", 2
        .Select
        Selection.ClearFormatting
        DeleteBlankSpace
        DeleteBlankLines
        If .Tables.Count = 0 Then
            .Content.ConvertToTable 0, 1
        ElseIf .Tables.Count = 1 Then
            .Content.Find.Execute "^p", , , 0, , , , , , "", 2
        Else
            MsgBox "仅限一表！", 0 + 16: End
        End If
        With .Tables(1)
            .Select
            TableDeleteBlankRows
            For Each c In .Range.Cells
                With c.Range
                    If .Text Like "????" Then .Characters(1).InsertAfter Text:="  "
                End With
            Next
            .Select
        End With
    End With
End Function


Function LastPound()
'最后一磅
    With ActiveDocument.Paragraphs
        With .Last.Range
            If .Text = vbCr Then .Delete
        End With
        With .Last.Range
            If .Text = vbCr Then
                With .Font
                    .Size = 1
                    .Kerning = 0
                    .DisableCharacterSpaceGrid = True
                End With
                With .ParagraphFormat
                    .LineSpacing = LinesToPoints(0.06)
                    .AutoAdjustRightIndent = False
                    .DisableLineHeightGrid = True
                End With
            End If
        End With
    End With
End Function


Function DeleteBlankLines()
'删除空行
    Dim i As Paragraph
    For Each i In ActiveDocument.Paragraphs
        With i.Range
            If Not .Information(12) Then
                If Asc(.Text) = 13 Then .Delete
            End If
        End With
    Next
End Function

Function DeleteBlankSpace()
'删除空格
    ActiveDocument.Content.Find.Execute "[  ^s^t]", , , 1, , , , , , "", 2
End Function

Function TableDeleteBlankRows()
'表格删除空行
    Dim r As Row
    For Each r In Selection.Tables(1).Rows
        If Len(Replace(Replace(r.Range, vbCr, ""), Chr(7), "")) = 0 Then r.Delete
    Next
End Function

如果使用 小恐龙公文插件 ,可以存为 桌签.vba , 用脚本功能直接执行.

否则需要自己复制粘贴到宏编辑器里再执行.