Attribute VB_Name ="AutoType"
Sub perfect()
'WORD自动排版并打印，楷体、正文分栏。
'页面设置部分，上下边距0.5cm，左右边距1cm，无页眉页脚，横排！
With ActiveDocument.PageSetup
.LineNumbering.Active =False
.Orientation = wdOrientLandscape
.TopMargin = CentimetersToPoints(0.5)
.BottomMargin = CentimetersToPoints(0.5)
.LeftMargin = CentimetersToPoints(1)
.RightMargin = CentimetersToPoints(1)
.
Gutter = CentimetersToPoints(0)
.HeaderDistance = CentimetersToPoints(0)
.FooterDistance = CentimetersToPoints(0)
.PageWidth = CentimetersToPoints(29.7)
.PageHeight = CentimetersToPoints(21)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter =False
.DifferentFirstPageHeaderFooter =False
.VerticalAlignment = wdAlignVerticalTop
.
SuppressEndnotes =False
.MirrorMargins =False
.TwoPagesOnOne =False
.BookFoldPrinting =False
.BookFoldRevPrinting =False
.BookFoldPrintingSheets =1
.GutterPos = wdGutterPosLeft
.LayoutMode = wdLayoutModeLineGrid
End With
'Application.Run MacroName:="space"
Application.Run MacroName:="enter"
'ctrl+Home使光标回归至首字符处（即标题前）
Selection.HomeKey Unit:=wdStory
'ctrl+Shift+↓使首段选中，目的是设置标题格式！
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend If Selection.Text =""+ vbCr Then Selection.Text = GetName + vbCrLf '以下为段落格式，字体楷体，字号小二，加粗，居中对齐
Selection.Font.Name="楷体_GB2312"
Selection.Font.Size=18
Selection.Font.Bold = wdToggle
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter '→使选中取消并移至下一段首。
Selection.MoveRight Unit:=wdCharacter, Count:=1
'回车，目的是使正文分栏时行文美观！
Selection.TypeParagraph
'ctrl+Shift+End使正文选中，目的是设置正文格式！
Selection.EndKey Unit:=wdStory, Extend:=wdExtend
'Application.Run MacroName:="adjust"
'调整图片、表格的宽度
'正文楷体，三号
Selection.Font.Name="楷体_GB2312"
Selection.Font.Name="Times New Roman"
Selection.Font.Size=16
'段落格式首行缩进！
With Selection.ParagraphFormat
.LeftIndent = CentimetersToPoints(0)
.
RightIndent = CentimetersToPoints(0)
.SpaceBefore =0
.SpaceBeforeAuto =False
.SpaceAfter =0
.SpaceAfterAuto =False
.LineSpacingRule = wdLineSpaceSingle
.Alignment = wdAlignParagraphJustify
.WidowControl =False
.KeepWithNext =False
.KeepTogether =False
.PageBreakBefore =False
.
NoLineNumber =False
.Hyphenation =True
.FirstLineIndent = CentimetersToPoints(0.35)
.OutlineLevel = wdOutlineLevelBodyText
.CharacterUnitLeftIndent =0
.CharacterUnitRightIndent =0
.CharacterUnitFirstLineIndent =2
.LineUnitBefore =0
.LineUnitAfter =0
.AutoAdjustRightIndent =True
.DisableLineHeightGrid =False
.
FarEastLineBreakControl =True
.WordWrap =True
.HangingPunctuation =True
.HalfWidthPunctuationOnTopOfLine =False
.AddSpaceBetweenFarEastAndAlpha =True
.AddSpaceBetweenFarEastAndDigit =True
.BaseLineAlignment = wdBaselineAlignAuto
End With
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type<> wdPrintView Then
ActiveWindow.ActivePane.View.Type= wdPrintView
End If
ActiveDocument.Range(Start:=Selection.Start, End:=Selection.Start). _
InsertBreak Type:=wdSectionBreakContinuous
Selection.Start = Selection.Start +1
'正文分为2栏，栏间有分隔线！
With Selection.PageSetup.TextColumns
.SetCount NumColumns:=2
.EvenlySpaced =True
.LineBetween =True
.
Width= CentimetersToPoints(13.47)
.Spacing = CentimetersToPoints(0.75)
End With
'返回文章开头
Selection.HomeKey Unit:=wdStory
'ctrl+Shift+↓使首段选中，目的是设置标题为文档的文件名！
Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend '取消对回车符的选中
'新建变量，存储文件名，即首段中不包含换行符的部分！
Dim temp
temp = GetName
If Not (Selection.Type=7Or Trim(Selection.Text) ="") Then
temp =Trim(Replace(Selection.Text, ":", "："))
End If
'设置保存路径，此处设为桌面处！
ChangeFileOpenDirectory "r:\"
'文件名为temp中的字符串
ActiveDocument.SaveAs FileName:=temp +".doc", FileFormat:=wdFormatDocument 'ActiveDocument.PrintOut
End Sub
Sub space()
'去除多余的空格（连续2个空格的情形）
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text ="  "
.Replacement.Text =""
.Forward=True
.Wrap = wdFindContinue
.Format=False
.MatchCase =False
.MatchWholeWord =False
.MatchByte =True
.MatchWildcards =False
.
MatchSoundsLike =False
.MatchAllWordForms =False
End With
Selection.Find.Execute Replace:=wdReplaceAll        Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting With Selection.Find
.Text ="  "
.Replacement.Text =" "
.Forward=True
.Wrap = wdFindContinue
.Format=False
.MatchCase =False
.
MatchWholeWord =False
.MatchByte =True
.MatchWildcards =False
.MatchSoundsLike =False
.MatchAllWordForms =False
End With
Selection.Find.Execute Replace:=wdReplaceAll    Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting With Selection.Find
.Text ="  "
.Replacement.Text =" "
.Forward=True
.
Wrap = wdFindContinue
.Format=False
.MatchCase =False
.MatchWholeWord =False
.MatchByte =True
.MatchWildcards =False
.MatchSoundsLike =False
.MatchAllWordForms =False
End With
Selection.Find.Execute Replace:=wdReplaceAll End Sub
Sub enter()
'清除连续2个的回车，避免出现太多的空白
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting With Selection.Find
.Text ="^p^p"
.Replacement.Text ="^p"
.Forward=True
.Wrap = wdFindContinue
.Format=False
.MatchCase =False
.MatchWholeWord =False
.MatchByte =False
.
MatchWildcards =False
.MatchSoundsLike =False
.MatchAllWordForms =False
End With
Selection.Find.Execute Replace:=wdReplaceAll        Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting With Selection.Find
.Text ="^p^p"
.Replacement.Text ="^p"
.Forward=True
.Wrap = wdFindContinue
.Format=False
.
MatchCase =False
.MatchWholeWord =False
.MatchByte =False
.MatchWildcards =False
.MatchSoundsLike =False
.MatchAllWordForms =False
End With
Selection.Find.Execute Replace:=wdReplaceAll    Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting With Selection.Find
.Text ="^p^p"
.Replacement.Text ="^p"
.
Forward=True
.Wrap = wdFindContinue
.Format=False
.MatchCase =False
.MatchWholeWord =False
.MatchByte =False
.MatchWildcards =False
.MatchSoundsLike =False
.MatchAllWordForms =False
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Sub adjust()
'设置所有图片宽度，未完成！
For i =1To Selection.InlineShapes.Count
Selection.InlineShapes(i).LockAspectRatio = msoTrue
Selection.InlineShapes(i).Width=360#
Next
For i =1To Selection.Tables.Count
Selection.Tables(i).PreferredWidth = CentimetersToPoints(12.7)
Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter Next
End Sub
Function GetName()
'返回当前的中文日期和时间
Dim y, m, d, h, mm, s, r
Randomize
y =Year(Now)
m =Month(Now)
If m <10Then m ="0"& m
d =Day(Now)
If d <10Then d ="0"& d
h =Hour(Now)
If h <10Then h ="0"& h
mm =Minute(Now)
If mm <10Then mm ="0"& mm
s =Second(Now)
If s <10Then s ="0"& s
pane
r =CInt(Rnd() *10)
If r <10Then r ="0"& r
'GetName = y & m & d & h & mm & s & r
GetName = y &"年"& m &"月"& d &"日"& h &"时"& mm &"分"& s &"秒"
'GetName = y + m + d + h + mm + s + r该语句不对，注意！！！！
'GetName=y&m&d&h&mm&s&r不对，须有空格
'a = y + m + d + h + mm + s + r
'MsgBox (a)显示2117
'a = "eee" + "www"
'MsgBox (a)显示eeewww
End Function

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。