html表格分页

最新推荐文章于 2023-09-30 13:23:47 发布

iteye_11687

最新推荐文章于 2023-09-30 13:23:47 发布

阅读量662

点赞数

最近要用TPageProducer替换模版，同时还须实现html分页，所见即所得，网上找了半天没发现，于是自己琢磨写了一个。代码用delphi6写，

由于实际需要，所以写例子的时候缩小了实际模型，供大家分享。这里写的例子表格，如果一整行的话肯定很容易控制

TDContent=class
TDtxt : String;
Htmltxt : String;
Height : Integer;
NextHeight : Integer;
constructor Create(aTDtxt : String);
end;

HtmlContent=class
Content : String;
Height : Integer;
TDList : TList;
constructor Create(aContent : String);
end;
PageHeight : Integer;
HeadHeight : Integer;
RestHeight : Integer;
clsHtmlContent : HtmlContent;
PageNo : Integer;
procedure MakeContent; //假设内容
function CaluHeight(height,NextHeight : Integer) : Integer; //计算页面高度
function NeedChangePage(height,NextHeight : Integer) :Boolean; //是否要分页
procedure SplitPage(allHtml : String); //分离页面
procedure MakeHtmlCode;//形成html

====实现代码

function TForm1.NeedChangePage(height,NextHeight : Integer) :Boolean; //是否要分页
begin
Result := False;
if RestHeight-height-NextHeight <= 0 then Result := True;
end;

procedure TForm1.SplitPage(allHtml : String);
var
tmppageNo : Integer;
lsSave : TStringList;
sPos,ePos : Integer;
s : String;
begin
lsSave := TStringList.Create;
tmpPageNo := 0;
sPos := 0;
while allHtml <> '' do
begin
tmpPageNo := tmpPageNo + 1;
ePos := pos('</BODY>',uppercase(allHtml));
if ePos > 0 then
begin
lsSave.Text := copy(allHtml,sPos,ePos + 6);
allHtml := copy(allHtml,ePos+7,length(allHtml));
s := 'e:/test/resulttest' + IntToStr(tmpPageNo) + '.html';
if fileExists(s) then deleteFIle(s);
try
lsSave.SaveToFile(S);
except
end;
end
else allHtml := '';
end;

end;

procedure TForm1.MakeHtmlCode;
var
i,j : Integer;
clsTDContent,clsTDContent1 : TDContent;
tmp1,tmp2,tmp3 : String;
bIsChange : Boolean;
sPos,ePos : Integer;
begin
tmp3 :='';
sPos := 0;
ePos := 0;
for i := 0 to clsHtmlContent.TDList.Count - 1 do
begin
bIsChange := False;
clsTDContent := clsHtmlContent.TDList[i];
clsTDContent.Htmltxt := '<td height="21" width="25%" colspan="3">' + clsTDContent.TDtxt + '</td>';
bIsChange := NeedChangePage(clsTDContent.Height,clsTDContent.NextHeight);
clsTDContent.Height := CaluHeight(clsTDContent.Height,clsTDContent.NextHeight);
if bIsChange or (i=clsHtmlContent.TDList.Count - 1) then //如果下一页要换页
begin
ePos := i;
tmp1 := '<tr>';
tmp1 := tmp1 + '<td height=' + IntToStr(42 * (ePos+1)) + ' rowspan=' + IntToStr(ePos-sPos+1) + '>母格</td>';
for j := sPos to ePos do
begin
clsTDContent1 := clsHtmlContent.TDList[j];
if j = sPos then //第一个单元格，则与母格在同一个<tr>中
begin
tmp1 := tmp1 + clsTDContent1.Htmltxt;
end
else
begin
tmp1 := tmp1 + '</tr><tr>' + clsTDContent1.Htmltxt;
end;
if j = ePos then tmp1 := tmp1 + '</tr>';
end;
if bIsChange then //防止i=clsHtmlContent.TDList.Count - 1条件成立时，未满足分页
begin
tmp2 := '</table></body><head><title>测试</title></head>' +
'<body>' +
'<table border="1" cellpadding="0" cellspacing="0" width="650" height="650">';
end
else tmp2 := '';
tmp3 := tmp3 + tmp1;
if tmp2 <> '' then tmp3 := tmp3 + tmp2;
sPos := ePos + 1; //变更起点为当前位置的后一个
end;
end;
clsHtmlContent.Content := tmp3;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
ls : TStringList;
s : String;
begin
ls := TStringList.Create;
PageProducer2.HTMLFile := 'D:/result.html';
MakeContent;//读取内容
MakeHtmlCode;//形成html
ls.Text := PageProducer2.Content;
SplitPage(ls.Text);
{
s := 'e:/test/resulttest.html';
if fileExists(s) then deleteFIle(s);
try
ls.SaveToFile(S);
except
end;
}

end;

procedure TForm1.MakeContent;
var
clsTDContent : TDContent;
i : Integer;
s : String;
begin
PageNo := 1;
clsHtmlContent := HtmlContent.Create('');

for i := 0 to 5 do
begin
s := 's' + IntToStr(i+1);
clsTDContent := TDContent.Create(s);
clsHtmlContent.TDList.Add(clsTDContent);
end;
end;

function TForm1.CaluHeight(height,NextHeight : Integer) : Integer;
var
tryRestHeight : Integer;
begin
tryRestHeight := RestHeight - height;
//如果容的下当前高度
if tryRestHeight >=0 then
begin
if (tryRestHeight - NextHeight) >= 0 then //如果容不下下一次的高度，则这次全部取完高度
begin
RestHeight := tryRestHeight;
Result := height;
end
else
begin
Result := RestHeight+50;//要换时，为了抵消掉页面设置小判断时提前分页，而分页时高度需要多设
RestHeight :=PageHeight;
end;
end
else Result := tryRestHeight; //否则返回小于0的数
end;