|
|
现象描述：用VBA随机生成word试卷（office 2007），发现word试卷出现下图现象，字符残缺，不固定，一些字符会奇怪的移位，如“错误”的“误”会一道下一个“错误”的后面，成为错误误，字符残缺问题在把段落样式修改后，得以解决，但个别字符移位情况不会改善。
解决思路：百度，但无解。
请教各位了！
.......................................................................................‘以下为随机生成试卷excel表代码
Sub 填空题()
Dim mr As Range
Dim tk As Integer
tk = Sheets("线路新安规(填空)复习题").[A65536].End(xlUp).Row - 1
For Each mr In Range("a2:a6")
Do
mr = Int(Rnd() * tk + 1)
Loop Until Application.CountIf(Range("a2:a6"), mr) = 1
'目标区域Range("a2:a11")中等于mr的个数为1
Next mr
单选题
End Sub
Sub 单选题()
Dim mr As Range
Dim tk As Integer
tk = Sheets("线路新安规（单选）复习题").[A65536].End(xlUp).Row - 1
For Each mr In Range("a7:a22")
Do
mr = Int(Rnd() * tk + 1)
Loop Until Application.CountIf(Range("a7:a22"), mr) = 1
'目标区域Range("a2:a11")中等于mr的个数为1
Next mr
多选题
End Sub
Sub 多选题()
Dim mr As Range
Dim xz As Integer
xz = Sheets("线路新安规（多选）复习题").[A65536].End(xlUp).Row - 1
For Each mr In Range("a23:a32")
Do
mr = Int(Rnd() * xz + 1)
Loop Until Application.CountIf(Range("a23:a32"), mr) = 1
Next mr
判断题
End Sub
Sub 判断题()
Dim mr As Range, pd As Integer
pd = Sheets("线路新安规（判断）复习题").[A65536].End(xlUp).Row - 1
For Each mr In Range("a33:a42")
Do
mr = Int(Rnd() * pd + 1)
Loop Until Application.CountIf(Range("a33:a42"), mr) = 1
Next mr
简答题
End Sub
Sub 简答题()
Dim mr As Range
Dim jd As Integer
jd = Sheets("线路新安规（简答）复习题").[A65536].End(xlUp).Row - 1
For Each mr In Range("a43:a44")
Do
mr = Int(Rnd() * jd + 1)
Loop Until Application.CountIf(Range("a43:a44"), mr) = 1
Next mr
问答题
End Sub
Sub 问答题()
Dim mr As Range
Dim wd As Integer
wd = Sheets("线路新安规（问答）复习题").[A65536].End(xlUp).Row - 1
For Each mr In Range("a45:a46")
Do
mr = Int(Rnd() * wd + 1)
Loop Until Application.CountIf(Range("a45:a46"), mr) = 1
Next mr
案例分析题
End Sub
Sub 案例分析题()
Dim mr As Range
Dim wd As Integer
wd = Sheets("线路新安规（线路案例分析）复习题").[A65536].End(xlUp).Row - 1
For Each mr In Range("a47:a48")
Do
mr = Int(Rnd() * wd + 1)
Loop Until Application.CountIf(Range("a47:a48"), mr) = 1
Next mr
End Sub
....................................................................................................
Private Sub CommandButton1_Click()'调用word生成试卷。
Dim rDATA As Range
Dim wd As Word.Application
Dim ret As Integer
ret = MsgBox("程序即将开始自动生成普考试卷！" & vbCrLf & vbCrLf & _
"现在就开始吗?", vbYesNo + vbInformation, "生成普考试卷")
Call 单选题1
If ret = vbNo Then Exit Sub
Set rDATA = Range(Range("Start1").Offset(1, 0), Range("Start1").End(xlDown))
Set wd = CreateObject("word.application") ' 创建 WORD 实例
wd.Visible = True ' 使 WORD 可见
AppActivate wd.Name ' 激活 WORD 窗口
With wd
.Documents.Add
With .Selection
.ParagraphFormat.SpaceBeforeAuto = True
.Font.Size = 18
.Font.Bold = True
.Text = [C1]
.EndKey
.TypeParagraph
End With
With .Selection
.ParagraphFormat.SpaceBeforeAuto = True
.Font.Size = 14
.Font.Bold = False
.Text = [B1]
.EndKey
.TypeParagraph
End With
'导入 EXCEL 文本
For Each rng In rDATA
With .Selection
'插入分类
If rng.Offset(0, 1) <> rng.Offset(-1, 1) Then
.ParagraphFormat.SpaceBeforeAuto = True ' 段前自动行距
.Text = LTrim(RTrim(rng.Offset(0, 1)))
.Font.Size = 14
.Font.Bold = True 'wdToggle ' 切换文本为加粗
'底纹灰度级 25
' .ParagraphFormat.Shading.BackgroundPatternColor = wdColorGray25
.EndKey ' 移到行末
.TypeParagraph ' 换行
.Font.Bold = wdToggle
'取消底纹灰度级
'.ParagraphFormat.Shading.BackgroundPatternColor = wdColorAutomatic
End If
' 插入问题
.ParagraphFormat.SpaceBeforeAuto = True
.Font.Size = 10.5
.Font.Bold = False ' wdToggle
.Text = rng.Offset(0, 3) & "." & rng.Offset(0, 2)
.EndKey
.TypeParagraph
End With
Next
'设置页脚
'.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
'.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
' .NormalTemplate.AutoTextEntries("第 X 页 共 Y 页").Insert Where:=.Selection.Range
' .ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End With
Set wd = Nothing
AppActivate Application.Name ' 激活 EXCEL 窗口
MsgBox "作业已完成, 请另行保存 Word 文档, 如果需要的话."
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2014-9-6 20:55
楼主
