如何将vb中的代码改过后直接在word的宏里边运行

qq_33965595 2016-03-18 04:10:47

Set wrd = CreateObject("Word.Application")
wrd.Visible = False
wrd.Documents.Open "c:\ks\word.doc"
'wrd.Documents("Word.doc").Activate
errstring = ""
rightstring = ""
With wrd.Documents("Word.doc").PageSetup
If .LeftMargin <> 79.4 Then
errstring = errstring & "左边距错误" & vbCrLf '本行代码检测左边距2.8cm
Else
rightstring = rightstring & "左边距设置正确" & vbCrLf
End If
If .RightMargin <> 79.4 Then
errstring = errstring & "右边距错误" & vbCrLf '本行代码检测右边距2.8cm
Else
rightstring = rightstring & "右边距设置正确" & vbCrLf
End If
If .TopMargin <> 85.05 Then
errstring = errstring & "上边距错误" & vbCrLf '本行代码检测上边距3cm
Else
rightstring = rightstring & "上边距设置正确" & vbCrLf
End If
If .BottomMargin <> 85.05 Then
errstring = errstring & "下边距错误" & vbCrLf '本行代码检测下边距3cm
Else
rightstring = rightstring & "下边距设置正确" & vbCrLf
End If
If .PaperSize <> wdPaperA4 Then
errstring = errstring & "纸型设置错误" & vbCrLf '检测是否为A4
Else
rightstring = rightstring & "纸型设置正确" & vbCrLf
End If
End With
Dim doctablecount, i As Integer
Dim str1 As String
doctablecount = wrd.Documents("Word.doc").Tables.Count
With wrd.Documents("Word.doc")
If .Sections(1).PageSetup.Orientation <> wdOrientLandscape Then
errstring = errstring & "页面方向设置错误" & vbCrLf '本行代码检测页面设置,wdOrientLandscape为横向，wdOrientPortrait为纵向
Else
rightstring = rightstring & "页面方向设置正确" & vbCrLf
End If

.ActiveWindow.View.Type = wdPrintView
.ActiveWindow.View.SeekView = wdSeekCurrentPageHeader '以上两行代码更改为页眉页脚视图
If .Sections(1).Headers(wdHeaderFooterPrimary).Range.Text <> "恐龙博物馆" & vbCr Or .Sections(1).Headers(wdHeaderFooterPrimary).Range.Paragraphs.Alignment <> wdAlignParagraphRight Then
errstring = errstring & "页眉设置错误" & vbCrLf '本行代码检测页眉文字及对齐方式
Else
rightstring = rightstring & "页眉设置正确" & vbCrLf
End If
.ActiveWindow.View.SeekView = wdSeekCurrentPageFooter
'If .Sections(1).Footers(wdHeaderFooterFirstPage).Range.Text <> "剑龙" & vbCr Or .Sections(1).Footers(wdHeaderFooterFirstPage).Range.Paragraphs.Alignment <> wdAlignParagraphCenter Then errstring = errstring & "页脚设置错误" & vbCrLf '本行代码检测页脚文字及对齐方式
If .Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers.Count = 0 Then
errstring = errstring & "没有在页脚中插入页码" & vbCrLf
ElseIf .Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers(1).Alignment <> wdAlignPageNumberCenter Then
errstring = errstring & "插入页码错误" & vbCrLf '本行代码检测是否在页脚中插入居中页码
Else
rightstring = rightstring & "插入页码正确" & vbCrLf
End If
.ActiveWindow.View.SeekView = wdSeekMainDocument
'以下代码剪切文档中的表格
If doctablecount <> 0 Then
For i = 1 To doctablecount
.Tables(i).Range.Cut
Next i
End If
'以下代码检测浮动对象
Dim etxteft, etxtbox, epic As Boolean
etxteft = etxtbox = epic = False
For Each Sh1 In wrd.Documents("Word.doc").Shapes
If Sh1.Type = msoTextEffect Then
If Sh1.TextEffect.Text <> "辽宁角龙" Then
errstring = errstring & "艺术字设置错误" & vbCrLf '本行检测艺术字
Else
rightstring = rightstring & "艺术字设置正确" & vbCrLf
End If
etxteft = True
End If
If Sh1.Type = msoTextBox Then
If Sh1.TextFrame.TextRange.Text <> "恐龙博物馆之一" & vbCr Or Sh1.TextFrame.Orientation <> 1 Then
errstring = errstring & "文本框版式或文本框内文字错误" & vbCrLf '检测文本框及方向：msoTextOrientationHorizontal(1)横向；msoTextOrientationVertical(4)纵向。
Else
rightstring = rightstring & "文本框版式和文字正确" & vbCrLf
End If
If Sh1.Line.ForeColor <> wdColorSkyBlue Then
errstring = errstring & "文本框边框色设置错误" & vbCrLf '本行检测是否蓝色边框
Else
rightstring = rightstring & "文本框边框色设置正确" & vbCrLf
End If
'If Sh1.Line.Visible = msoTrue Then errstring = errstring & "文本框边框线条色设置错误" & vbCrLf '本行检测无线条色
If Sh1.Fill.ForeColor <> wdColorGold Then
errstring = errstring & "文本框填充色设置错误" & vbCrLf
Else
rightstring = rightstring & "文本框填充色设置正确" & vbCrLf
End If
If Sh1.WrapFormat.Type <> wdWrapSquare Then
errstring = errstring & "文本框环绕方式设置错误" & vbCrLf '本行检测文本框四周型环绕
Else
rightstring = rightstring & "文本框环绕方式设置正确" & vbCrLf
End If
etxtbox = True
End If
If Sh1.Type = msoLinkedPicture Or Sh1.Type = msoPicture Then
If Sh1.WrapFormat.Type <> wdWrapTight Then
errstring = errstring & "图片环绕方式设置错误" & vbCrLf '本行检测图片紧密型环绕
Else
rightstring = rightstring & "图片环绕方式设置正确" & vbCrLf
Sh1.ConvertToInlineShape
End If
With wrd.Documents("Word.doc").InlineShapes(1)
'MsgBox wrd.Documents("Word.doc").InlineShapes(1).ScaleHeight & " " & wrd.Documents("Word.doc").InlineShapes(1).ScaleWidth
If (.ScaleHeight <= 99.5 Or .ScaleHeight >= 100.5) And (.ScaleWidth <= 99.5 Or .ScaleWidth >= 100.5) Then
errstring = errstring & "图片缩放设置错误" & vbCrLf
Else
rightstring = rightstring & "图片缩放正确" & vbCrLf
End If
End With
epic = True
End If
Next
If etxteft = False Then errstring = errstring & "文档中没有插入艺术字" & vbCrLf
If etxtbox = False Then errstring = errstring & "文档中没有插入文本框" & vbCrLf
If epic = False Then errstring = errstring & "从网页中复制图片错误" & vbCrLf
End If
'阅卷代码到此结束
msgbox(errstring)
msgbox(rightstring)

...全文