vb自动生成格式试卷代码.doc

vb自动生成word格式试卷代码Dim TempRec1 As New ADODB.RecordsetDim A1 As StringDim MyWord As Word.ApplicationDim WordDoc As Word.DocumentDim BTextBoxDim MyRange As Word.RangeDim MyTable As Word.TableDim MyCell As Word.CellDim MyCells As Word.CellsDim MyCols As Word.ColumnsDim A() As StringDim B() As StringDim ColN As IntegerDim ArrBytes() As ByteDim FreeFileNumber As IntegerDim Lngsize As LongSet TempRec1.ActiveConnection = DBConIf Combo1.ListIndex = -1 Then MsgBox 没有选择试卷名称,不能生成试卷!, vbOKOnly, 提示 Exit SubEnd IfTempRec1.Open select id from sjtx where sjbm= & SjbmArry(Combo1.ListIndex + 1) & If TempRec1.RecordCount = 0 Then MsgBox 没有选择试卷题型顺序,不能生成试卷!, vbOKOnly, 提示 Exit SubEnd IfTempRec1.Close Load Form13 Form13.Height = 810 Form13.Width = 4680 CenterForm Form13, MDIForm1 Form13.Show Me.Enabled = False创建新文档On Error GoTo ErrorEndStart: Set WordDoc = MyWord.Documents.Add If Option1.Value Then With WordDoc.PageSetup .PageHeight = InchesToPoints(11.69) .PageWidth = InchesToPoints(8.27) End WithEnd IfIf 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 = 16A1$ = Trim(Combo1.Text)MyWord.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenterMyWord.Selection.TypeText A1$MyWord.Selection.TypeText Chr(13)插入科目名称MyWord.Selection.Font.Name = 宋体MyWord.Selection.Font.Size = 15A1$ = & Trim(Combo2.Text) & + Chr(13)MyWord.Selection.Font.Bold = TrueMyWord.Selection.ParagraphFormat.Alignment = wdAlignParagraphCenterMyWord.Selection.TypeText A1$MyWord.Selection.Font.Bold = False插入注意事项If TempRec1.State = 1 Then TempRec1.CloseEnd IfTempRec1.Open select Zysx from Sjbt where Sjbm= & SjbmArry(Combo1.ListIndex + 1) & If TempRec1.RecordCount = 0 Then MsgBox 没有找到试卷的注意事项，不能生成试卷!, vbOKOnly, 提示 GoTo ErrorEndEnd IfA1$ = TempRec1.Fields(Zysx).ValueMyWord.Selection.Font.Name = 黑体MyWord.Selection.Font.Size = 10.5MyWord.Selection.ParagraphFormat.Alignment = wdAlignParagraphLeftMyWord.Selection.TypeText A1$MyWord.Selection.Font.Name = 宋体从Sjtx表中提取题型名称、数量、附加说明If TempRec1.State = 1 Then TempRec1.CloseEnd IfTempRec1.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.IDIf TempRec1.RecordCount = 0 Then MsgBox 没有找到试卷所属题型，不能生成试卷!, vbOKOnly, 提示 GoTo ErrorEndEnd IfColN = TempRec1.RecordCountIf 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 TempRec1.MoveFirst For j = 1 To N Lngsize = TempRec1.Fields(stnr).ActualSize ArrBytes = TempRec1.Fields(stnr).GetChunk(Lngsize) FreeFileNumber = 1 Open App.Path & tempst.doc For Binary As #FreeFileNumber Put #FreeFileNumber, , ArrBytes Close #FreeFileNumber MyWord.Selection.TypeText Str(j) MyWord.Selection.TypeText . MyWord.Selection.InsertFile FileName:=App.Path & tempst.doc, ConfirmConversions:=False MyWord.Selection.Collapse Direction:=wdCollapseEnd TempRec1.MoveNext Next TempRec1.Close Next/添加页码WordDoc.Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberCenter, FirstPage:=TrueSet MyRange = WordDoc.Sections(1).Footers(wdHeaderFooterPrimary).RangeMyWord.NormalTemplate.AutoTextEntries(第 X 页 共 Y 页).Insert Where:=MyRange, RichText:=TrueMyRange.ParagraphFormat.Alignment = wdAlignParagraphCenter 段落居中对齐End If在第一轧添加试卷左则文本框 MyWord.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=1 A1 = 学校 _班级 _ 学号 _姓名 _ Set BTextBox = WordDoc.Shapes.AddTextbox(msoTextOrientationU