彩色标签（宏）2019-8-3 更新！

413191246se · 发表于 2019-8-6 03:14

* 最近两天，三易其稿，本着模块化编程、分层推进思想，重写了自动排版宏，首次使用了模块级变量。
* 老师，如果有时间、兴趣，请指点一下《公文》宏和《普通》宏的具体编程思路、方法、算法、语句写法等，提速、优化、标准是我盼望的；如无兴趣并不强求，老师的身体健康是最重要的，编程也只是我的业余爱好。

三羧酸 · 发表于 2019-8-6 15:46

有跑偏的现象，也不知道怎么能够解决？

413191246se · 发表于 2019-8-6 20:51

楼上朋友，你好！请问，你用的 Word 是什么版本？我在 Word2003 和 Word2007 上运行是没有问题的。

413191246se · 发表于 2019-8-7 13:54

本帖最后由 413191246se 于 2019-8-8 12:38 编辑

略。。。。

sylun · 发表于 2019-8-8 21:25

413191246se 发表于 2019-8-6 03:14
* 最近两天，三易其稿，本着模块化编程、分层推进思想，重写了自动排版宏，首次使用了模块级变量。
* 老师 ...

作为练手并支持，按照37楼上传文档的思路写了部分代码，请楼主测试效果。很久没写百行的代码了。
至于公文，建议用模板，事前防范，一目了然。因后面才自动编辑排版，难免有疏忽，如因此发出有病公文可不好办。

生成档案标签邮件合并主文档.rar (1.67 KB, 下载次数: 28)

413191246se · 发表于 2019-8-9 01:57

* 不好意思！老师请重新打包一下，上传一下。因为我下载后无法打开，提示损坏。
* 最近几天，我也几易其稿，昨天早上（8月8号）终于定稿，决定公文不变，普通样式，标题2345与正文字号保持一致，这样比较整齐划一，比较美观大方（因标题和正文字号大小不一，产生了尴尬的版面。如 5号字正文与三号字标题2）。
* 还有一个问题：刚才我反复测试《落款》宏(Selection对象)和《落款Update》宏(ActiveDocument对象)，总是各有千秋，不知道怎么科学地测试谁更快一些。
* 老师，我最新作品是：8月8号的自动排版宏，如果有空闲和兴趣，请老师再指点一二。主要是《公文》宏和《普通》宏，别的未更新。

413191246se · 发表于 2019-8-9 01:59

* 老师，忘了说了，别人的文档，我给排成公文，我并不拟稿，怎么用模板？
* 谢谢老师！辛苦了！请注意休息。。。

sylun · 发表于 2019-8-9 20:39

413191246se 发表于 2019-8-9 01:57
* 不好意思！老师请重新打包一下，上传一下。因为我下载后无法打开，提示损坏。
* 最近几天，我也几易其 ...

刚才尝试下载并解压，能正常打开文本文件。干脆直接将代码发出，只是长了一点，不好看。现在连文本文档都要压缩上传。
至于楼主的两个宏，因代码有几千行，过程很多，注释很少，有用wd常量名也有用常量值，易读性不强。不知楼主是基于什么原因写那么多过程，用于对OCR识别文档的整理吗？如果是对普通拟文稿排版，不应有这么复杂吧？
没找到落款Update宏。我很少用selection对象，通常用range，因selection对象是一个全局性的，虽然方便灵活，但也可有其不确定性，一不小心会出错。另外，selection对象总在当前页面活动窗格，其变动会带动页面滚动，即使关闭刷新也会给人一种慢的感觉。

Sub Main()
'生成档案标签邮件合并主文档并执行合并
Dim oDoc As Document
On Error GoTo hd
Application.ScreenUpdating = False
Set oDoc = Documents.Add
myPageSetup oDoc
TablesAdding oDoc
oDoc.Content.InsertParagraphAfter
Mailmerging oDoc
Application.ScreenUpdating = True
Exit Sub
hd:
MsgBox "程序运行出现异常，退出！", vbCritical
End Sub
Sub myPageSetup(myDoc As Document)
'主文档页面设置
With myDoc.PageSetup
.PaperSize = wdPaperA4
.Orientation = wdOrientLandscape
.TopMargin = CentimetersToPoints(0.5)
.BottomMargin = CentimetersToPoints(0.5)
.LeftMargin = CentimetersToPoints(0.5)
.RightMargin = CentimetersToPoints(0.5)
End With
End Sub
Sub TablesAdding(myDoc As Document)
'在新文档插入嵌套表格，设置首个标签的框线，并以此为标准套用
Dim oTable As Table
Dim aTable As Table
Dim aCell As Cell
Dim i As Integer
Options.DefaultBorderLineWidth = wdLineWidth150pt
Options.DefaultBorderLineStyle = wdLineStyleSingle
Set oTable = myDoc.Tables.Add(myDoc.Content, 1, 10, wdWord8TableBehavior)
With oTable
For Each aCell In .Range.Cells
With aCell.Range
.Collapse wdCollapseStart
If i = 0 Then
Set aTable = aCell.Tables.Add(.Duplicate, 7, 1)
With aTable
With .Borders
.InsideLineStyle = Options.DefaultBorderLineStyle
.InsideLineWidth = Options.DefaultBorderLineWidth
.OutsideLineStyle = wdLineStyleThinThickThinSmallGap
.OutsideLineWidth = wdLineWidth450pt
.OutsideColorIndex = wdGreen
End With
.Range.Cells(2).Borders(wdBorderTop).Visible = False
.Range.Cells(5).Borders(wdBorderTop).Visible = False
SetCellHeightAndText i, myDoc, aCell.Tables(1)
End With
Else
.FormattedText = aTable.Range.FormattedText '主文档后续标签套用首个标签样式
With .Tables(1).Range.Cells(1).Range
.Collapse wdCollapseStart
myDoc.MailMerge.Fields.AddNext .Duplicate
End With
End If
End With
i = i + 1
Next
End With
End Sub
Sub SetCellHeightAndText(n As Integer, myDoc As Document, myTable As Table)
'设置单个标签内容及格式
Dim i As Integer
Dim nCell As Cell
Dim cellheight() As Variant
Dim fieldnames() As Variant
Dim fontsizes() As Variant
Dim textwidths() As Variant
Dim myField As MailMergeField
cellheight = Array(1.2, 1.2, 1.8, 1.8, 9, 1.8, 1.8) '标签中各单元格的高度
textwidths = Array(2, 2, 2.2, 1.2, 8.2, 2.2, 2.2) '标签各项内容的宽度
fontsizes = Array(18, 18, 22, 22, 26, 22, 22) '标签各项内容的字符磅值
fieldnames = Array("", "单位名称", "档案名称", "编号", "案卷名称", "类别", "年度")
myTable.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
myTable.Rows.Alignment = wdAlignRowCenter
myTable.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
For Each nCell In myTable.Range.Cells
nCell.HeightRule = wdRowHeightExactly
nCell.Height = CentimetersToPoints(cellheight(i))
nCell.Range.Font.Size = fontsizes(i)
If i > 0 Then
myDoc.MailMerge.Fields.Add nCell.Range, fieldnames(i)
nCell.Range.FitTextWidth = CentimetersToPoints(textwidths(i))
With nCell.Range.Font
If i < 3 Then
.NameFarEast = "宋体"
.Color = wdColorRed
ElseIf i = 4 Then
.NameFarEast = "方正小标宋简体"
nCell.Range.Orientation = wdTextOrientationVerticalFarEast
Else
.NameFarEast = "楷体_GB2312"
End If
End With
End If
i = i + 1
Next
End Sub
Sub Mailmerging(myDoc As Document)
'设置并执行邮件合并
With myDoc.MailMerge
.MainDocumentType = wdDirectory
.Destination = wdSendToNewDocument
.SuppressBlankLines = False
.DataSource.FirstRecord = wdDefaultFirstRecord
.DataSource.LastRecord = wdDefaultLastRecord
If Dialogs(81).Show = -1 Then .Execute True '如手动打开数据源则执行合并
End With
End Sub

复制代码

413191246se · 发表于 2019-8-10 02:29

* 我这儿下载后，有时正常，有时提示损坏。也有可能是我电脑上有木马病毒或 RAR 版本跟不上了。
*《公文》宏和《普通》宏，仅仅是对正常公文/普通文档进行排版处理，有些地方也不符合公文要求。
* Selection/Range 这两个对象，我现在明白，前者激活对象，后者不激活对象，光标不动，速度较快。
* 最近几天，针对模块化编程，反反复复，几易其稿，也许在家里电脑较慢，排版速度感觉不快，但有时又想，也没必要太快，现在也不算慢了。又针对《落款》宏进行了增强，多一些代码，增加一些舒适吧。
* 谢谢老师！辛苦了！再次请多多注意身体。。。（老师的代码，我要研究一番。。。）

woyaofacai · 发表于 2019-10-15 20:24

这个宏生成的是A4横向，目前多数档案是A4竖立摆放的，所以生成的标签应该要纵向才对，如果改一下就好了

		自动登录	找回密码
密码			免费注册

[分享] 彩色标签（宏）2019-8-3 更新！

最新热点 /1