这是以前做的一个组卷小程序，是从题库中随机抽取题，并生成试卷。希望对你有所帮助。
procedure TWebModule1.GetWordDoc(SortID, TestNum: Integer);
var
TestArray: Array[1..100] of Integer;
AnswerArray: Array[1..100] of String;
i, j, rndNum, iRecCount: Integer;
blQuit: Boolean;
Nothing, FileName: OleVariant;
FPath: string;
begin
SetLength(FPath, 255);
GetModuleFileName(hInstance, Pchar(FPath), 255);
FileName := Copy(FPath, 1, Pos('ToOffice', FPath) -1) + 'TestDoc.Doc';
with qrTest do
try
if Active then Close;
Parameters.ParamByName('SortID').Value := SortID;
Open;
iRecCount := RecordCount;
//判断题数是否超出范围
if TestNum > iRecCount then TestNum := iRecCount;
try
WordDoc.Connect;
WordApp.ConnectTo(WordDoc.Application);
WordApp.Visible := False;
//生成题头
WordApp.Selection.ParagraphFormat.Alignment := wdAlignParagraphCenter;
WordApp.Selection.Font.Name := '黑体';
WordApp.Selection.Font.Bold := 12;
WordApp.Selection.Font.Size :=18;
WordApp.Selection.TypeText('培训考试试卷' + #13);
WordApp.Selection.Font.Size :=14;
WordApp.Selection.TypeText('姓名： 考试日期：' +
FormatDateTime('yyyy-MM-dd', Date) + ' 分数：' + #13);
//随机抽题
WordApp.Selection.ParagraphFormat.Alignment := wdAlignParagraphLeft;
for i := 1 to TestNum do
begin
//生成一个随机数
rndNum := RandomRange(1, iRecCount);
blQuit := False;
//排除重复值
while not blQuit do
begin
for j := 1 to 100 do
if rndNum = TestArray[j] then
begin
rndNum := RandomRange(1, iRecCount);
blQuit := False;
Break;
end
else
blQuit := true;
end;
TestArray := rndNum;
if Locate('ID', rndNum, [loCaseInsensitive]) then
begin
WordApp.Selection.Font.Bold := 0;
WordApp.Selection.Font.Name := '黑体';
WordApp.Selection.Font.Size := 12;
WordApp.Selection.TypeText(IntToStr(i) + '.' +
FieldByName('Question').AsString + #13);
WordApp.Selection.Font.Name := '宋体';
WordApp.Selection.Font.Size := 11;
WordApp.Selection.TypeText(FieldByName('Options').AsString + #13);
AnswerArray := FieldByName('Answer').AsString;
end;
end;
//da.Close;
//生成答案
Nothing := 0;
WordApp.Selection.InsertBreak(Nothing);
WordApp.Selection.Font.Name := '黑体';
WordApp.Selection.ParagraphFormat.Alignment := wdAlignParagraphCenter;
WordApp.Selection.Font.Bold := 12;
WordApp.Selection.Font.Size :=18;
WordApp.Selection.TypeText('参考答案' + #13 + #13);
WordApp.Selection.ParagraphFormat.Alignment := wdAlignParagraphLeft;
WordApp.Selection.Font.Size :=12;
for i := 1 to TestNum do
begin
WordApp.Selection.Font.Bold := 16;
WordApp.Selection.Font.Size := 12;
if i <= 9 then
WordApp.Selection.TypeText(' ' + IntToStr(i) + '.' + UpperCase(AnswerArray) + ' ')
else
WordApp.Selection.TypeText(IntToStr(i) + '.' + UpperCase(AnswerArray) + ' ');
if i mod 5 = 0 then
WordApp.Selection.TypeText(#13 + #13);
end;
//生成答题卡
WordApp.Selection.InsertBreak(Nothing);
WordApp.Selection.Font.Bold := 16;
WordApp.Selection.Font.Size :=16;
WordApp.Selection.ParagraphFormat.Alignment := wdAlignParagraphCenter;
WordApp.Selection.TypeText('培训考试标准答题卡' + #13 + #13);
WordApp.Selection.ParagraphFormat.Alignment := wdAlignParagraphLeft;
WordApp.Selection.Font.Size :=10;
for i := 1 to 50 do
begin
if i <= 9 then
WordApp.Selection.TypeText(' ' + IntToStr(i) + '._____ ')
else
WordApp.Selection.TypeText(IntToStr(i) + '._____ ');
if i mod 5 = 0 then
WordApp.Selection.TypeText(#13 + #13);
end;
//将WordDoc文档对象的内容保存为DOC文档
WordDoc.SaveAs(FileName);
except
on E: Exception do
FErr := '创建Word文档错误，错误信息如下： ' + #13 + E.Message;
end;
finally
WordDoc.Disconnect;
WordDoc.Close;
WordApp.Quit;
WordApp.Disconnect;
end;
end;
