vb自动组卷代码.rar_VB自动组卷_组卷源码_组卷系统 vb_自动组卷系统

Dim TempRec1 As New ADODB.Recordset Dim A1 As String 'Dim MyWord As Word.Application Dim WordDoc As Word.Document Dim BTextBox Dim MyRange As Word.Range Dim MyTable As Word.Table Dim MyCell As Word.Cell Dim MyCells As Word.Cells Dim MyCols As Word.Columns Dim A() As String Dim B() As String Dim ColN As Integer Dim ArrBytes() As Byte Dim FreeFileNumber As Integer Dim Lngsize As Long Set TempRec1.ActiveConnection = DBCon If Combo1.ListIndex = -1 Then MsgBox "没有选择试卷名称,不能生成试卷!", vbOKOnly, "提示" Exit Sub End If TempRec1.Open "select id from sjtx where sjbm='" & SjbmArry(Combo1.ListIndex + 1) & "'" If TempRec1.RecordCount = 0 Then MsgBox "没有选择试卷题型顺序,不能生成试卷!", vbOKOnly, "提示" Exit Sub End If TempRec1.Close Load Form13 Form13.Height = 810 Form13.Width = 4680 CenterForm Form13, MDIForm1 Form13.Show Me.Enabled = False '创建新文档 On Error GoTo ErrorEnd Start: Set WordDoc = MyWord.Documents.Add If Option1.Value Then With WordDoc.PageSetup .PageHeight = InchesToPoints(11.69) .PageWidth = InchesToPoints(8.27) End With End If If Option2.Value Then '试卷分栏设置 WordDoc.PageSetup.TogglePortrait With WordDoc.PageSetup .PageHeight = InchesToPoints(11.69) .PageWidth = InchesToPoints(16.54) End With WordDoc.PageSetup.TextColumns.SetCount NumColumns:=2 WordDoc.PageSetup.TextColumns.Spacing = CentimetersToPoints(4) End If '插入试卷名称 MyWord.Selection.Font.Name = "宋体" MyWord.Selection.Font.Size = 16 A1$ = Trim(Combo1.Text) MyWord.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter MyWord.Selection.TypeText A1$ MyWord.Selection.TypeText Chr(13) '插入科目名称 MyWord.Selection.Font.Name = "宋体" MyWord.Selection.Font.Size = 15 A1$ = "《" & Trim(Combo2.Text) & "》" + Chr(13) MyWord.Selection.Font.Bold = True MyWord.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter MyWord.Selection.TypeText A1$ MyWord.Selection.Font.Bold = False '插入注意事项 If TempRec1.State = 1 Then TempRec1.Close End If TempRec1.Open "select Zysx from Sjbt where Sjbm='" & SjbmArry(Combo1.ListIndex + 1) & "'" If TempRec1.RecordCount = 0 Then MsgBox "没有找到试卷的注意事项，不能生成试卷!", vbOKOnly, "提示" GoTo ErrorEnd End If A1$ = TempRec1.Fields("Zysx").Value MyWord.Selection.Font.Name = "黑体" MyWord.Selection.Font.Size = 10.5 MyWord.Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft MyWord.Selection.TypeText A1$ MyWord.Selection.Font.Name = "宋体" '从Sjtx表中提取题型名称、数量、附加说明 If TempRec1.State = 1 Then TempRec1.Close End If TempRec1.Open "select tx.txmc,Sjtx.Fzap,Sjtx.Fjsm from Sjtx,Tx where Sjtx.Txbm=tx.txbm and Sjtx.Sjbm='" & SjbmArry(Combo1.ListIndex + 1) & "' order by sjtx.ID" If TempRec1.RecordCount = 0 Then MsgBox "没有找到试卷所属题型，不能生成试卷!", vbOKOnly, "提示" GoTo ErrorEnd End If ColN = TempRec1.RecordCount If ColN < 12 Then ReDim A(1 To TempRec1.RecordCount, 1 To 3) TempRec1.MoveFirst For i = 1 To TempRec1.RecordCount A(i, 1) = TempRec1.Fields("Txmc").Value If TempRec1.Fields("Fzap").Value <> "" Then A(i, 2) = TempRec1.Fields("Fzap").Value Else A(i, 2) = "" End If If Trim(TempRec1.Fields("Fjsm").Value) <> "" Then A(i, 3) = TempRec1.Fields("Fjsm").Value Else A(i, 3) = "" End If TempRec1.MoveNext Next TempRec1.Close '将对应数学数字转换成中文数字 ReDim B(1 To ColN) TempRec1.Open "select Zwsz from SdZ" TempRec1.MoveFirst For i = 1 To ColN B(i) = TempRec1.Fields("Zwsz").Value TempRec1.MoveNext Next TempRec1.Close '创建表格将对应题目标号填写到表中 Set MyTable = MyWord.Selection.Tables.Add(MyWord.Selection.Range, 2, ColN + 2) Set MyCols = MyTable.Columns '设置列宽 MyCols(1).Width = 46.5 '列宽通过320/列数获取 For i = 1 To ColN If Option1.Value Then MyCols(i + 1).Width = 330 \ ColN End If If Option2.Value Then MyCols(i + 1).Width = 370 \ ColN End If Next MyCols(ColN + 2).Width = 50 '设置行高 MyTable.Rows(1).Height = 25 MyTable.Rows(2).Height = 25 '表格外边框 MyTable.Borders.OutsideLineStyle = wdLineStyleSingle '表格内边框 MyTable.Borders.InsideLineStyle = wdLineStyleSingle '表格居中 MyTable.Rows.Alignment = wdAlignRowCenter '表格中文本对齐方式 '垂直居中 MyTable.Rows(1).Cells.VerticalAlignment = wdCellAlignVerticalCenter MyTable.Rows(2).Cells.VerticalAlignment = wdCellAlignVerticalCenter '水平居中 ' For k = 1 To ColN + 2 ' MyTable.Cell(1, k).Select ' Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter ' Next Set MyCell = MyTable.Cell(1, 1): MyCell.Select: MyWord.Selection.TypeText "题 目" '题目名称从试卷表中的题目类型名称获取 For i = 1 To ColN Set MyCell = MyTable.Cell(1, i + 1): MyCell.Select: MyWord.Selection.TypeText B(i) Next Set MyCell = MyTable.Cell(1, ColN + 2): MyCell.Select: MyWord.Selection.TypeText "总 分" Set MyCell = MyTable.Cell(2, 1): MyCell.Select: MyWord.Selection.TypeText "得 分" Set MyCell = Nothing Set MyTable = Nothing MyWord.Selection.GoToNext wdGoToLine MyWord.Selection.TypeText Chr(13) '可用循环生成试题 '///// For i = 1 To ColN '题型阅卷表格和题型说明 MyWord.Selection.Font.Name = "黑体" Set MyTable = MyWord.Selection.Tables.Add(MyWord.Selection.Range, 2, 3) MyTable.Borders.OutsideLineStyle = wdLineStyleSingle MyTable.Borders.OutsideColor = wdColorWhite MyTable.Borders.InsideLineStyle = wdLineStyleSingle MyTable.Borders.InsideColor = wdColorWhite MyTable.Rows(1).Cells(1).Borders.OutsideColor = wdColorBlack MyTable.Rows(1).Cells(2).Borders.OutsideColor = wdColorBlack MyTable.Rows(2).Cells(1).Borders.OutsideColor = wdColorBlack MyTable.Rows(2).Cells(2).Borders.OutsideColor = wdColorBlack Set MyRange = WordDoc.Range(MyTable.Cell(1, 3).Range.Start, MyTable.Cell(2, 3).Range.End) MyRange.Cells.Merge For k = 1 To 2 MyTable.Columns(k).Width = 50 Next MyTable.Rows.Height = 25 If Option1.Value Then MyTable.Columns(3).Width = 325 End If If Option2.Value Then MyTable.Columns(3).Width = 365 End If Set MyCols = MyTable.Columns Set MyCell = MyTable.Cell(1, 1): MyCell.Select: MyWord.Selection.TypeText "得 分" Set MyCell = MyTable.Cell(2, 1): MyCell.Select: MyWord.Selection.TypeText "评分人" MyTable.Rows.Alignment = wdAlignRowCenter MyTable.Cell(1, 1).VerticalAlignment = wdCellAlignVerticalCenter MyTable.Cell(2, 1).VerticalAlignment = wdCellAlignVerticalCenter MyTable.Cell(1, 3).VerticalAlignment = wdCellAlignVerticalCenter '题号+题型+分值安排 MyWord.Selection.Font.Name = "宋体" MyWord.Selection.Font.Size = 10.5 MyWord.Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft If A(i, 3) <> "" Then Set MyCell = MyTable.Cell(1, 3): MyCell.Select: MyWord.Selection.TypeText B(i) & "、" & A(i, 1) & ".(" & A(i, 2) & ")" & Chr(10) & A(i, 3) Else Set MyCell = MyTable.Cell(1, 3): MyCell.Select: MyWord.Selection.TypeText B(i) & "、" & A(i, 1) & ".(" & A(i, 2) & ")" End If Set MyCell = MyTable.Cell(1, 3): MyCell.Select Set MyCell = Nothing Set MyTable = Nothing MyWord.Selection.GoToNext wdGoToLine MyWord.Selection.GoToNext wdGoToLine '对应题型的试题 If TempRec1.State = 1 Then TempRec1.Close End If '按难度系数升序排列试题 TempRec1.Open "select st.stnr from st,sjst where st.stbm=sjst.stbm and sjst.txmc='" & A(i, 1) & "' and sjst.Sjbm='" & SjbmArry(Combo1.ListIndex + 1) & "' order by sjst.ndxs" If TempRec1.EOF And TempRec1.BOF Then Exit Sub End If If TempRec1.RecordCount = 0 Then MsgBox "没有找到相关试题,不能生成试卷,请检查!", vbOKOnly, "提示" GoTo NoSt End If N = TempRec1.RecordCount TempRec