求助守柔、sylun word分割单选题

wang-way · 发表于 2013-6-12 22:19

本帖最后由 wang-way 于 2013-6-13 12:30 编辑

求助用WORD VBA分别获取单选题的引言题干和A B C D四个选项，在网友的帮助下已经初步实现。但带有许多地方需要完善，求助大师们……
原文内容：（粘贴至WORD文档中哦）

一、选择题

1．下列四图中能够正确表示地理事物和现象之间关系的是

A．① B．② C．③ D．④

2．某地区植被退化或丧失、土壤物质和地表水流失、岩石溶蚀与侵蚀、基岩裸露、土地生物生产力退化。这一地表过程是

A．砂岩地区受风力强烈侵蚀作用产生的自然演化过程，形成甘新多沙漠戈壁的自然景观

B．黄土高原黄土塌陷，体现地下水的过度开采而造成的人为演化过程

C．青藏多大河湖泊，体现水土流失严重的沟壑地区的环境演化过程

D．石灰岩地区在自然和人类活动作用下的综合演化过程，形成云贵川石漠化景观

右图是我国某省级行政区略图，读图完成第3题。

3．该省级行政区的城市发展特征是

A. 城市南多北少 B.城市沿河分布明显

C. 城市化水平高 D.处于逆城市化阶段

读我国东部某城市2005～2010年“外来人口流向调查统计图”，回答第4题。

4．该市外来人口流向的变化，将会

A．促进郊区的城市化进程，城市规模扩大

B．中心城区的人口密度下降，解决城区的环境污染问题

C．郊区的人口密度不断增加使城区的第三产业大量向郊区转移

D．使城市化水平下降，城市的服务范围缩小

5．根据表中数据，不能直接分析得出的结论是

A．人口素质有明显提升 B．经济发展中“人口红利”优势明显

C．劳动力向东部迁移增多 D．城市化进程处于加快阶段

右图表示对某地区不同等级的城市聚落分布进行模式化处理得出的图像。读图回答第6题。

6．右图所示地区，等级最高的城市是

A．a B．b

C．c D．d

右图表示上海市2004年制造业就业比重的空间分布，读图回答7~8题。

7．图中甲最可能的功能区是

A．住宅区 B．商业区

C．工业区 D．科教文化区

8．某大企业计划在上海布局产业各部门，关于该企业各部门布局及区位条件，下列对应关系最合理的是

A．甲——核心生产部门---配套企业多

B．乙——管理和研发部门---环境容量大

C．丙——配套生产部门---土地成本低

D．乙——营销部门---接近能源地

9．材料数据反映出我国目前存在的相关社会问题有

①人口基数大，净增人口多

②自然增长率过快，人口增长类型处于“传统型”阶段

③开始出现人口老龄化现象，社会负担加重

④城市化水平较低，农村劳动力过剩

⑤贫困人口增多，社会治安混乱

A．①③④ B．①②⑤

C．②③④ D．①③⑤

代码：（二楼哦）

求助大神们的问题：

1、第3题 A选项后面有若干空格，运行代码后。获取的内容为问号？？？有没有办法只修改上述代码中通配符来获取？

2.1、求助办法，根据引言的内容（“回答第X题”）判断引言属于第X题。

2.2、同上根据引言的内容（“回答第X~Y题”）判断，第X~Y题为一组组合题。

3.第9题的题干内容比较特殊……没有办法得到1234点描述

4、假如试卷上有图片内容，有没有办法根据图片插入的位置（一般位于题目和四个选项之间）判断图片属于第X题？

5、其实，我是想做一个属于自己的题库，将来再学习如何组卷…… 求指导啊……

wang-way · 发表于 2013-6-12 22:28

[code=vb]Option Explicit
Type Dxt '定义单选题数据结构
Options(1 To 6) As String
End Type

Sub SplitDxts() '分离单选题

Dim dxts(1 To 100) As Dxt '声明单选题数组
Dim FindText(1 To 6) As String '声明通配符形式数组
Dim iCount, m, n As Integer

'初始化查找文本通配符格式
FindText(1) = "[^13]([!^13]@)([0-9]@)题>"
FindText(2) = "<[0-9]{1,2}[．.]*^13"
FindText(3) = "<A[．.]([!^13]@)[^32^13]"
FindText(4) = "<B[．.]([!^13]@)[^32^13]"
FindText(5) = "<C[．.]([!^13]@)[^32^13]"
FindText(6) = "<D[．.]([!^13]@)[^32^13]"

For m = 1 To 6
      iCount = 0
      With Selection
         .HomeKey wdStory '回到文档开始
         With .Find '开始查询
            .Text = FindText(m)
            .MatchWildcards = 1
            .Forward = True
            Do While .Execute = True
                  'Selection.Bookmarks("\para").Range.Select
                  iCount = iCount + 1 '统计题目数量
                  If m = 1 Then
                     dxts(iCount).Options(m) = Replace(Selection.Range, Chr(13), "")
                  Else
                     dxts(iCount).Options(m) = Selection.Range
                  End If
                  'Selection.Collapse wdCollapseEnd
            Loop
         End With
      End With
Next m

'测试
For m = 1 To 6
      For n = 1 To iCount
         Debug.Print n & "—" & dxts(n).Options(m)
      Next n
Next m

End Sub[/code]

wang-way · 发表于 2013-6-12 23:54

坐等回复！！

wang-way · 发表于 2013-6-13 03:54

本帖最后由 wang-way 于 2013-6-13 04:02 编辑

Option Explicit
Type YinYan
Content As String
Start As Integer
End As Integer
Combine As Boolean '是否为组合题
End Type
Type Dxt '定义单选题数据结构
Yy As YinYan
Question As String
Options(1 To 4) As String
End Type
Sub SplitDxts() '分离单选题
Dim dxts(1 To 100) As Dxt '声明单选题数组
Dim OptionFindText(1 To 6) As String '声明通配符形式数组
Const QuestionFindText As String = "<[0-9]{1,2}[．.]*^13"
Const YyFindText As String = "[^13]([!^13]@)([0-9]@)题>"
Dim iCount, m, n, yyCount As Integer
'初始化查找文本通配符格式
OptionFindText(1) = "<A[．.]([!^13]@)[^32^13]"
OptionFindText(2) = "<B[．.]([!^13]@)[^32^13]"
OptionFindText(3) = "<C[．.]([!^13]@)[^32^13]"
OptionFindText(4) = "<D[．.]([!^13]@)[^32^13]"
yyCount = 0
Selection.HomeKey wdStory
Dim tempYy As YinYan
With ActiveDocument.Content.Find
.Text = YyFindText
.MatchWildcards = 1
.Forward = True
Do While .Execute
yyCount = yyCount + 1
tempYy.Content = Replace(.Parent.Text, Chr(13), "")
.Parent.Select '不写出错
If InStr(1, .Parent.Text, "-") > 0 Then
With Selection.Find
.Text = "([0-9]@)-([0-9]@)"
.MatchWildcards = 1
.Forward = True
If .Execute = True Then
tempYy.Combine = True
tempYy.Start = CInt(Mid(.Parent.Text, 1, InStr(1, .Parent.Text, "-") - 1))
tempYy.End = CInt(Mid(.Parent.Text, InStr(1, .Parent.Text, "-") + 1))
dxts(tempYy.Start).Yy.Content = tempYy.Content
dxts(tempYy.Start).Yy.Combine = tempYy.Combine
dxts(tempYy.Start).Yy.Start = tempYy.Start
dxts(tempYy.Start).Yy.End = tempYy.End
End If
End With
Else
With Selection.Find
.Text = "[!^1-^127][0-9]@题"
.MatchWildcards = 1
.Forward = True
If .Execute = True Then
tempYy.Combine = False
tempYy.Start = CInt(Mid(.Parent.Text, 2, Len(.Parent.Text) - 2))
tempYy.End = tempYy.Start
dxts(tempYy.Start).Yy.Content = tempYy.Content
dxts(tempYy.Start).Yy.Combine = tempYy.Combine
dxts(tempYy.Start).Yy.Start = tempYy.Start
dxts(tempYy.Start).Yy.End = tempYy.End
End If
End With
End If
Loop
End With
iCount = 0
Selection.HomeKey wdStory
With ActiveDocument.Content.Find
.Text = QuestionFindText
.MatchWildcards = 1
.Forward = True
Do While .Execute = True
iCount = iCount + 1
dxts(iCount).Question = .Parent.Text
Loop
End With
For m = 1 To 4
iCount = 0
Selection.HomeKey wdStory
With ActiveDocument.Content.Find
.Text = OptionFindText(m)
.MatchWildcards = 1
.Forward = True
Do While .Execute = True
iCount = iCount + 1
dxts(iCount).Options(m) = .Parent.Text
Loop
End With
Next m
For m = 1 To iCount
If dxts(m).Yy.Content = "" Then
Debug.Print "########无引言的题目【开始】##########"
Debug.Print dxts(m).Question
Debug.Print dxts(m).Options(1)
Debug.Print dxts(m).Options(2)
Debug.Print dxts(m).Options(3)
Debug.Print dxts(m).Options(4)
Debug.Print "#########无引言的题目【结束】##########"
Else
If dxts(m).Yy.Combine = False Then
Debug.Print "################################有引言单题【开始】###"
Debug.Print dxts(m).Yy.Content
Debug.Print dxts(m).Question
Debug.Print dxts(m).Options(1)
Debug.Print dxts(m).Options(2)
Debug.Print dxts(m).Options(3)
Debug.Print dxts(m).Options(4)
Debug.Print "################################有引言单题【结束】###"
Else
Debug.Print "#####有引言组合题【开始】#############################"
Debug.Print dxts(m).Yy.Content
For n = dxts(m).Yy.Start To dxts(m).Yy.End
Debug.Print dxts(n).Question
Debug.Print dxts(n).Options(1)
Debug.Print dxts(n).Options(2)
Debug.Print dxts(n).Options(3)
Debug.Print dxts(n).Options(4)
Next
Debug.Print "####有引言组合题【结束】##############################"
m = n - 1
End If
End If
Next m
End Sub

复制代码

zhanglei1371 · 发表于 2013-6-14 15:53

1.对于第7-9题这样的引言可用通配符：第[0-9-]@题来查找；
2.对于第九题的情况，可修改下else后面的部分：
                  Else
                     If m = 2 Then
                        Set mg = Selection.Range
                        Do While InStr(mg.Next(wdParagraph, 1), "A") = False
                              mg.MoveEnd wdParagraph, 1
                              js = js + 1
                              If js > 6 Then js = 0: Exit Do
                              Debug.Print mg
                        Loop
                     End If
                     dxts(iCount).Options(m) = mg

wang-way · 发表于 2013-6-14 20:23

zhanglei1371 发表于 2013-6-14 15:53
1.对于第7-9题这样的引言可用通配符：第[0-9-]@题来查找；
2.对于第九题的情况，可修改下else后面的部分： ...

大致明白您的思路了在题干下一段查找字母A 直到查到为止。谢谢您！

wang-way · 发表于 2013-6-14 21:02

zhanglei1371 发表于 2013-6-14 15:53
1.对于第7-9题这样的引言可用通配符：第[0-9-]@题来查找；
2.对于第九题的情况，可修改下else后面的部分： ...

还要继续请教下一个问题！第4问

zhanglei1371 · 发表于 2013-6-15 11:22

第四个问题，昨天QQ不是已发给你了？
其实思路就是，从上到下循环段落，判断每一段是否有图形，有的话就选中该段内容，判断该段第一个字是否含有0-9，没有的话再判断选中段落的前后段，找到为止
Sub 选择图片所在段落()
With ActiveDocument.ActiveWindow.View
      .Type = wdPrintView
      .ShowObjectAnchors = True
End With
Dim s As Shape
For Each s In ActiveDocument.Shapes
      Dim pa As Paragraph
      For Each pa In s.Anchor.Paragraphs
         pa.Range.Select
         If Asc(pa.Range.Characters(1)) > 48 And Asc(pa.Range.Characters(1)) < 57 _
            Or Asc(pa.Previous.Range.Characters(1)) > 48 And Asc(pa.Previous.Range.Characters(1)) < 57 _
            Or Asc(pa.Range.Characters(1)) > 48 And Asc(pa.Range.Characters(1)) < 57 _
            Then
            Dim mry As Range
            Set mry = ActiveDocument.Range(pa.Previous.Range.Start, pa.Next.Range.End)
            mry.Find.Execute "[0-9]@.", , , 1
            Debug.Print mry.Find.Parent
         End If
      Next
Next
End Sub

wang-way · 发表于 2013-6-15 13:17

本帖最后由 wang-way 于 2013-6-15 14:25 编辑

zhanglei1371 发表于 2013-6-15 11:22
第四个问题，昨天QQ不是已发给你了？
其实思路就是，从上到下循环段落，判断每一段是否有图形，有的话就选 ...

等我看明白调试一下就很好了！再次感谢.
试了一下，发现普适性不强。跟代码无关，而是跟平时大家排版不遵守一定规范有关。实在难以统一。

三次握手 · 发表于 2019-3-23 21:45

数据规范化很重要。

		自动登录	找回密码
密码			免费注册