|
本帖最后由 413191246se 于 2015-7-24 14:13 编辑
* 证书数据源格式:Word2003表格,且表格数目必须只有一个!
* 证书字段:[姓名][课题][证书编号](3字段必须!),[等级][序号][单位](可有可无)。* 证书自动编号:有两种格式。一是纯数字(建议最好少于15位,否则会为为科学计数法),二是形如"ZD2015037",会自动向下编号。
* 邮件合并证书数据源后的合并结果文档,有的课题文字过多,达到3行或4行,需要折行,可以应用《证书调整行数》宏自动循环遍历每节,强制每节第2段落为2行(实际是减少字符缩放),然后打印。
**************《证书调整行数》(宏)代码如下:
Sub 证书调整行数()
Dim i As Section
For Each i In ActiveDocument.Sections
i.Range.Paragraphs(2).Range.Select
Do
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine
Selection.MoveDown Unit:=wdLine, Count:=1
If Asc(Selection) <> 13 Then
Selection.Paragraphs(1).Range.Select
Selection.ParagraphFormat.CharacterUnitFirstLineIndent = 2.35 '正文小一
Selection.Font.Scaling = Selection.Font.Scaling - 5
Else
Exit Do
End If
Loop
Next
End Sub
********《证书自动编号》(宏)最终完美版****代码如下:*****
Sub 证书自动编号()
'检查表格数目
If ActiveDocument.Tables.Count <> 1 Then MsgBox "证书数据源仅允许有一个表格!", vbOKOnly + vbCritical, "证书自动编号": End
'删除换行符/回车符
ActiveDocument.Content.Find.Execute findtext:="^l", ReplaceWith:="", Replace:=wdReplaceAll
ActiveDocument.Content.Find.Execute findtext:="^13", ReplaceWith:="", Replace:=wdReplaceAll
'删除表外文字
If ActiveDocument.Paragraphs(1).Range.Information(wdWithInTable) = False Then ActiveDocument.Paragraphs(1).Range.Delete
ActiveDocument.Paragraphs.Last.Range.Delete
'删除段落首尾空格
Selection.WholeStory
CommandBars.FindControl(ID:=123).Execute
CommandBars.FindControl(ID:=122).Execute
'声明变量
Dim t As Table, c As Cell, r As Range, i As String, m As Long, n As Long, u As Column, lngName As Long, lngSubject As Long, lngGrade As Long, lngNum As Long, p As String, e As Long
Set t = ActiveDocument.Tables(1)
m = t.Rows.Count
'规范字段
For Each c In t.Rows(1).Cells
Set r = c.Range
If r Like "*序*号*" Then
r.Text = "序号"
ElseIf r Like "*姓*名*" Then
r.Text = "姓名"
ElseIf r Like "*课*题*" Then
r.Text = "课题"
ElseIf r Like "*单*位*" Or r Like "*学*校*" Then
r.Text = "单位"
ElseIf r Like "*等*级*" Or r Like "*奖*项*" Then
r.Text = "等级"
ElseIf r Like "*编*号*" Then
r.Text = "证书编号"
End If
Next
'检查字段
For Each c In t.Rows(1).Cells
Set r = c.Range
If r Like "姓名*" Then
lngName = lngName + 1
ElseIf r Like "课题*" Then
lngSubject = lngSubject + 1
ElseIf r Like "等级*" Then
lngGrade = lngGrade + 1
ElseIf r Like "证书编号*" Then
lngNum = lngNum + 1
End If
Next
If (lngName = 1 And lngSubject = 1) And lngNum = 1 Then
If lngGrade >= 2 Then MsgBox "[等级]字段过多!请检查!", vbOKOnly + vbCritical, "证书自动编号": End
If lngGrade = 0 Then If MsgBox("[等级]字段不存在!是否继续?", vbYesNo + vbCritical, "证书自动编号") = vbNo Then End
Else
MsgBox "[姓名][课题][证书编号]字段不存在(或过多)!请检查!", vbOKOnly + vbCritical, "证书自动编号": End
End If
'删除各列所有空格(课题列除外)
For Each u In t.Columns
If Not (u.Cells(1).Range Like "课题*") Then u.Select Else GoTo skipset
Selection.Font.Color = wdColorBlue
Selection.Find.Execute findtext:=" ", ReplaceWith:="", Replace:=wdReplaceAll
Selection.SelectColumn
Selection.Find.Execute findtext:="^w", ReplaceWith:="", Replace:=wdReplaceAll
skipset:
Next
'证书编号<=15
t.Rows(1).Select
Selection.Find.Execute findtext:="证书编号"
n = Selection.Information(wdStartOfRangeColumnNumber)
t.Cell(2, n).Range.Select
Selection.MoveEnd Unit:=wdCharacter, Count:=-1
Selection.Range.CharacterWidth = wdWidthHalfWidth
i = Selection.Text
If Asc(i) = 13 Then
If MsgBox("[证书编号]列没有初始编号!请选择!" & vbCr & vbCr & "是:在光标所在单元格中输入证书编号 否:不输入证书编号(继续)", vbYesNo + vbCritical, "证书自动编号") = vbYes Then End
Else
If IsNumeric(i) = False Then
If Selection Like "[A-Z][A-Z]#######*" Then e = 0: p = Left(i, 2): i = Right(i, Len(i) - 2) Else MsgBox "证书编号不标准![纯数字]和[ZD2014357]格式可以自动编号!", vbOKOnly + vbCritical, "证书自动编号": End
Else
e = 1
End If
i = i + 1
ActiveDocument.Range(Start:=t.Cell(3, n).Range.Start, End:=t.Cell(m, n).Range.End).Select
For Each c In Selection.Cells
Set r = c.Range
If e = 1 Then r.Text = i Else r.Text = p & i
i = i + 1
Next
End If
'等级
If lngGrade = 1 Then
t.Rows(1).Select
Selection.Find.Execute findtext:="等级"
n = Selection.Information(wdStartOfRangeColumnNumber)
ActiveDocument.Range(Start:=t.Cell(2, n).Range.Start, End:=t.Cell(m, n).Range.End).Select
For Each c In Selection.Cells
Set r = c.Range
r.MoveEnd Unit:=wdCharacter, Count:=-1
If Len(r.Text) = 0 Then r.Shading.BackgroundPatternColor = wdColorRed
If r Like "[11一壹]*" Then r.Text = "一等"
If r Like "[22二贰]*" Then r.Text = "二等"
If r Like "[33三叁]*" Then r.Text = "三等"
Next
End If
'姓名
t.Rows(1).Select
Selection.Find.Execute findtext:="姓名"
n = Selection.Information(wdStartOfRangeColumnNumber)
ActiveDocument.Range(Start:=t.Cell(2, n).Range.Start, End:=t.Cell(m, n).Range.End).Select
For Each c In Selection.Cells
Set r = c.Range
r.MoveEnd Unit:=wdCharacter, Count:=-1
If Len(r.Text) = 0 Then
r.Shading.BackgroundPatternColor = wdColorRed
ElseIf Len(r.Text) = 1 Then
r.Shading.BackgroundPatternColor = wdColorBrightGreen
ElseIf Len(r.Text) = 2 Then
r.Characters(1).InsertAfter Text:=Space(2)
ElseIf Len(r.Text) >= 4 Then
r.Shading.BackgroundPatternColor = wdColorBrightGreen
End If
Next
'课题
t.Rows(1).Select
Selection.Find.Execute findtext:="课题"
n = Selection.Information(wdStartOfRangeColumnNumber)
Selection.SelectColumn
Selection.Font.Color = wdColorBlue
Selection.Find.Execute findtext:="《", ReplaceWith:="〈", Replace:=wdReplaceAll
Selection.SelectColumn
Selection.Find.Execute findtext:="》", ReplaceWith:="〉", Replace:=wdReplaceAll
ActiveDocument.Range(Start:=t.Cell(2, n).Range.Start, End:=t.Cell(m, n).Range.End).Select
For Each c In Selection.Cells
Set r = c.Range
r.MoveEnd Unit:=wdCharacter, Count:=-1
If Len(r.Text) = 0 Then r.Shading.BackgroundPatternColor = wdColorRed
If r.Characters(1) = "〈" And r.Characters.Last = "〉" Then r.Characters(1).Delete: r.Characters.Last.Delete
If r.Characters(1) = "〈" Then
r.Select
Selection.Find.Execute findtext:="〉"
If Selection.Find.Found = False Then r.Characters(1).Delete
End If
If r.Characters.Last = "〉" Then
r.Select
Selection.Find.Execute findtext:="〈"
If Selection.Find.Found = False Then r.Characters.Last.Delete
End If
Next
'序号
t.Rows(1).Select
Selection.Find.Execute findtext:="序号"
If Selection.Find.Found = True Then
n = Selection.Information(wdStartOfRangeColumnNumber)
ActiveDocument.Range(Start:=t.Cell(2, n).Range.Start, End:=t.Cell(m, n).Range.End).Delete
ActiveDocument.Range(Start:=t.Cell(2, n).Range.Start, End:=t.Cell(m, n).Range.End).Select
Selection.Range.ListFormat.ApplyListTemplate ListTemplate:=ListGalleries( _
wdNumberGallery).ListTemplates(1), ContinuePreviousList:=False, ApplyTo:= _
wdListApplyToWholeList, DefaultListBehavior:=wdWord10ListBehavior
Selection.ParagraphFormat.TabStops.ClearAll
ActiveDocument.DefaultTabStop = CentimetersToPoints(0)
End If
t.Rows(1).Range.Font.Bold = True
t.Rows(1).Range.Font.Color = wdColorAutomatic
Selection.HomeKey Unit:=wdStory
End Sub
|
|