【delphi开源代码栏目提醒】：文章导读：在新的一年中，各位网友都进入紧张的学习或是工作阶段。网学会员整理了delphi开源代码-frm_Html.pas的相关内容供大家参考，祝大家在新的一年里工作和学习顺利！
unit frm_Html;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, DB, Grids, DBGrids, ADODB, StdCtrls, OleCtrls, SHDocVw, XPMan,
ExtCtrls;
type
TfrmTBToHtml = class(TForm)
ADOConn: TADOConnection;
ATList: TADOTable;
DSList: TDataSource;
SaveD: TSaveDialog;
GroupBox2: TGroupBox;
GBxList: TGroupBox;
DBGList: TDBGrid;
Splitter1: TSplitter;
GroupBox1: TGroupBox;
WBrow: TWebBrowser;
GroupBox3: TGroupBox;
BtnConvert: TButton;
BtnClose: TButton;
procedure BtnConvertClick(Sender: TObject);
procedure BtnCloseClick(Sender: TObject);
private
procedure Convert(FileName:string);
procedure readPic(Rec:integer;const filename:string);
{ Private declarations }
public
{ Public declarations }
end;
var
frmTBToHtml: TfrmTBToHtml;
implementation
{$R *.dfm}
procedure TFrmTBToHtml.Convert(FileName:string);
var
FHtml:TextFile;
i,j:integer;
Strdata:string;
begin
assignfile(FHtml,FileName);
try
Rewrite(FHtml);
except
Showmessage('打开文件时出错！！');
end;
strdata:='';
Strdata:='<!DOCTYPE HTML PUBLIC "-//W3C//DTD
HTML 4.01 Transitional//EN"'+#13+
'"http://www.w3.org/TR/html4/loose.dtd">'+#13+
'<html>'+#13+
'<head>'+#13+
'<meta http-equiv="Content-Type" content="text/html; charset=gb2312">'+#13+
'</head>'+#13+
'<body>'+#13+
'<p>'+#13+
'<center>'+#13+
'<h1>人员信息表</h1>'+#13+
'</center>'+#13;
Writeln(FHtml,strdata);
Strdata:='</p>'+#13+
'<table width="80%" height="50" border="1" align="center">';
Writeln(FHtml,strdata);
Writeln(FHtml,'<tr align="center">');
For i:=0 to ATList.Fields.Count-1 do
begin
Strdata:='<th>'+#13;
strdata:=Strdata+ATlist.Fields.Fields[i].FieldName;
Strdata:=Strdata+'</th>'+#13;
Writeln(FHtml,strdata);
end;
Writeln(FHtml,'</tr>');
For i:=0 to Atlist.RecordCount -1 do
begin
Writeln(FHtml,'<tr align="center">');
For j:=0 to ATList.Fields.Count-1 do
begin
Strdata:='<td>'+#13;
//if j = ATlist.Fields.Count-1 then
if ATlist.Fields.Fields[j].IsBlob then
begin
readpic(j,FileName+'Image\'+ATList.Fields.Fields[0].asstring+'.jpg');
Strdata:= Strdata+'<img src="'+filename+'Image\'+ATList.Fields.Fields[0].asstring+'.jpg'+'" width="70" height="80">';
end
else
strdata:=Strdata+ATlist.Fields.Fields[j].AsString;
Strdata:=Strdata+'</td>'+#13;
Writeln(FHtml,strdata);
end;
Writeln(FHtml,'</tr>');
ATlist.Next;
//add data
end;
Strdata:='</table>'+#13+
'</body>' +#13+
'</html>' +#13;
Writeln(FHtml,strdata);
Closefile(FHtml);
end;
procedure TfrmTBToHtml.BtnConvertClick(Sender: TObject);
begin
with SaveD do
begin
if Execute then
begin
createdir(Filename+'Image');
Convert(FileName);
wbrow.Navigate(filename);
end;
end;
end;
procedure TFrmTBTohtml.readPic(Rec:integer;const filename:string);
var
stream1:TMemoryStream;
sd:TStringStream;
begin
with ATlist do
begin
if not Fields.Fields[rec].IsNull then
begin
Sd:=TStringStream.Create(fieldbyname('picture').AsString);
Stream1:=TMemoryStream.Create;
try
if sd.Size > 0 then
begin
Stream1.CopyFrom(Sd,sd.Size);
stream1.SaveToFile(filename);
end;
finally
stream1.Free;
sd.Free;
end;
end;
end;
end;
procedure TfrmTBToHtml.BtnCloseClick(Sender: TObject);
begin
Close;
end;
end.
相关文章
2013-9-1
