📄 unit1.~pas
字号:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, IdFTP, IdBaseComponent, IdComponent,
IdTCPConnection, IdTCPClient, IdHTTP, DBXpress, xmldom, XMLIntf,
msxmldom, XMLDoc, DB, Grids, DBGrids, DBClient, SimpleDS, SqlExpr,
ComCtrls,Inifiles, ToolWin, FMTBcd;
type
TFAdmin = class(TForm)
IdHTTP1: TIdHTTP;
IdFTP1: TIdFTP;
Timer_Send_Outfile: TTimer;
SQLConnection1: TSQLConnection;
DSBOutfile: TSimpleDataSet;
SimpleDataSet2: TSimpleDataSet;
SDSpublicationinfo: TSimpleDataSet;
DataSource1: TDataSource;
XML: TXMLDocument;
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
dsbAFFIX_ISSUANCE: TSimpleDataSet;
DBGrid2: TDBGrid;
Timer_Send_Msg: TTimer;
GroupBox1: TGroupBox;
Label1: TLabel;
Memo1: TMemo;
Label2: TLabel;
Memo2: TMemo;
DSBOutfileF_GUID: TStringField;
DSBOutfileF_REFGUID: TStringField;
DSBOutfileF_ORGANIZATION: TStringField;
DSBOutfileF_INDATE: TSQLTimeStampField;
DSBOutfileF_OUTGOINGDATE: TSQLTimeStampField;
DSBOutfileF_TYPE: TStringField;
DSBOutfileF_INFILETYPE: TStringField;
DSBOutfileF_OTHERORG: TStringField;
DSBOutfileF_SEQ: TFMTBCDField;
DSBOutfileF_ORGCODE: TStringField;
DSBOutfileF_YEAR: TFMTBCDField;
DSBOutfileF_FILENO: TFMTBCDField;
DSBOutfileF_TITLE: TStringField;
DSBOutfileF_TOPIC: TStringField;
DSBOutfileF_TEXTBODY: TBlobField;
DSBOutfileF_FILETYPE: TStringField;
DSBOutfileF_STATUS: TStringField;
DSBOutfileF_DEALTYPE: TStringField;
DSBOutfileF_RECEIVESOURCE: TStringField;
DataSource2: TDataSource;
PageControl2: TPageControl;
TabSheet3: TTabSheet;
DBGrid1: TDBGrid;
PageControl3: TPageControl;
TabSheet4: TTabSheet;
DBGrid3: TDBGrid;
dsbAFFIX_ISSUANCEF_GUID: TStringField;
dsbAFFIX_ISSUANCEF_ATTACHGUID: TStringField;
dsbAFFIX_ISSUANCEF_TITLE: TStringField;
dsbAFFIX_ISSUANCEF_TEXTBODY: TBlobField;
dsbAFFIX_ISSUANCEF_FILETYPE: TStringField;
ControlBar1: TControlBar;
ToolBar1: TToolBar;
btnExit: TButton;
btnStartSendInfo: TButton;
Button1: TButton;
Button2: TButton;
btnStartSend: TButton;
btnopenDB: TButton;
SQLQuery1: TSQLQuery;
procedure btnStartSendClick(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure btnStartSendInfoClick(Sender: TObject);
procedure Timer_Send_OutfileTimer(Sender: TObject);
procedure WLog(Alog: string);
procedure wjsc(lTmpPath,lFileName: string);
procedure wjsc2(lTmpPath,lFileName: string);
procedure btnExitClick(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
procedure btnopenDBClick(Sender: TObject);
function getItemName(item:string):string;
private
{ Private declarations }
LogFile: Textfile; //日志文件
public
{ Public declarations }
lTmpPath,httpaddress,ftphost,ftpuser,ftppwd,ftpPath,ftphost2,ftpuser2,ftppwd2,
lTmpFileName,filetype,lFileName,title ,lFileName1,lFileName2,lFileName3: String;
lslog:boolean;
end;
var
FAdmin: TFAdmin;
SysPath, logDate: string;
implementation
{$R *.dfm}
function getLogDate:string;
begin
Result := FormatDateTime('yyyymmdd',Now);
end;
function GetGUID:string;
var
id:TGUID;
sID, sa: string;
begin
sID := '';
if CreateGUID(id) = s_ok then
begin
sa := guidtostring(id);
sID := Copy(sa, 2, 8) + Copy(sa, 11, 4) + Copy(sa, 16, 4)
+ Copy(sa, 21, 4) + Copy(sa, 26, 12);
end;
Result := sID;
end;
procedure TFAdmin.WLog(Alog: string); //写进日志
var
FileHandle: Integer;
begin
if not fileexists(SysPath + '\LogFile'+ getLogDate +'.INI') then
begin
FileHandle := FileCreate(SysPath + '\LogFile'+ getLogDate +'.INI');
FileClose(FileHandle);
end;
AssignFile(LogFile, SysPath + '\logFile'+ getLogDate +'.ini');
Append(LogFile);
Writeln(Logfile, Alog);
Closefile(LogFile);
end;
procedure TFAdmin.btnStartSendClick(Sender: TObject);
begin
if btnStartSend.Caption = '启动发布公文' then
begin
DSBOutfile.Active:=true;
btnStartSend.Caption := '停止发布公文';
Timer_Send_Outfile.Enabled := True;
end
else begin
btnStartSend.Caption := '启动发布公文';
Timer_Send_Outfile.Enabled := False;
end;
end;
function TFAdmin.getItemName(item:string):string;
begin
SQLQuery1.Close;
SQLQuery1.SQL.Text:='select * from T_LMDYB where id='''+item+'''';
SQLQuery1.Open;
if SQLQuery1.IsEmpty then
result:=''
else
result:=SQLQuery1.fieldbyname('NAME').AsString;
end;
procedure TFAdmin.Button2Click(Sender: TObject);
var
item,itemName:String;
date:TdateTime;
node1,node2,node3,node4:IXMLNode;
li:integer;
lFileNametext:string;
begin
if lTmpPath='' then
lTmpPath := 'd:\temp';
if not DirectoryExists(lTmpPath) then
CreateDir(lTmpPath);
lslog:=true; //启动循环标志
DSBOutfile.open;
DSBOutfile.Refresh;
DSBOutfile.First;
while not DSBOutfile.Eof do
begin
lTmpFileName := GetGUID;
//1.输出文件 上传ftp
item:=DSBOutfile.FieldByName('F_ORGCODE').AsString; //机关代字要对应南京提供ＩＤ对照表取出ＩＤ
itemName:=getItemName(item);
title:=itemName+'['+DSBOutfile.FieldByName('F_YEAR').AsString+']'+DSBOutfile.FieldByName('F_FILENO').AsString+'号 '+DSBOutfile.FieldByName('f_title').AsString;
if item='' then
item:='211';
filetype:=DSBOutfile.FieldByName('F_FILETYPE').AsString;
lFileNametext := lTmpFileName+filetype;
lFileName := lTmpPath + '\' + lFileNametext;
date:=DSBOutfile.FieldByName('F_OUTGOINGDATE').AsDateTime;
TBlobField(DSBOutfile.FieldByName('F_TEXTBODY')).SaveToFile(lFileName);
wjsc(lTmpPath,lFileNametext); //上传正文到ftp
wjsc2(lTmpPath,lFileNametext); //上传到服务器2
//输出附件同上 ;先到附件表中查询
//循环
if not dsbAFFIX_ISSUANCE.IsEmpty then
begin
li:=0;
while not dsbAFFIX_ISSUANCE.Eof do
begin
li:=li+1;
filetype:= dsbAFFIX_ISSUANCE.FieldByName('F_FILETYPE').AsString;
if li=1 then
begin
title:=title+'附件1';
lTmpFileName := GetGUID;
lFileName1:= lTmpFileName+filetype; //附件1
TBlobField(dsbAFFIX_ISSUANCE.FieldByName('F_TEXTBODY')).SaveToFile(lTmpPath + '\' +lFileName1); //输出时带默认路径
wjsc(lTmpPath,lFileName1);
wjsc2(lTmpPath,lFileName1); //上传到服务器2
end;
if li=2 then
begin
title:=title+'附件2';
lTmpFileName := GetGUID;
lFileName2:= lTmpFileName+filetype; //附件2
TBlobField(dsbAFFIX_ISSUANCE.FieldByName('F_TEXTBODY')).SaveToFile(lTmpPath + '\' +lFileName2); //输出时带默认路径
wjsc(lTmpPath,lFileName2);
wjsc2(lTmpPath,lFileName2); //上传到服务器2
end;
if li=3 then
begin
title:=title+'附件3';
lTmpFileName := GetGUID;
lFileName3:= lTmpFileName+filetype; //附件3
TBlobField(dsbAFFIX_ISSUANCE.FieldByName('F_TEXTBODY')).SaveToFile(lTmpPath + '\' +lFileName3); //输出时带默认路径
wjsc(lTmpPath,lFileName3);
wjsc2(lTmpPath,lFileName3); //上传到服务器2
end;
dsbAFFIX_ISSUANCE.Next;
end;
end;
with XML do
begin
XML.Clear;
XML.Add('<main></main>');
Active := True;
Encoding := 'gb2312'; //编码格式(ANSI)
DocumentElement.AddChild('editioe',0).NodeValue := '1.0'; //整段代码编译通过
DocumentElement.AddChild('copyright',1).NodeValue := '版权';
node1:=DocumentElement.AddChild('article',2);
node1.AddChild('id',0).NodeValue:=title;
node1.AddChild('title',0).NodeValue:=title; //标题里最好不要带有ＨＴＭＬ标记
// node1.AddChild('text',0).NodeValue:=text; //信息科发布信息内容时用
node1.AddChild('text',1).NodeValue:=ftpPath+lFileNametext; //发布公文时文件路径
if lFileName1<>'' then node1.AddChild('caption',1).NodeValue:=ftpPath+lFileName1; //发布公文时附件路径
if lFileName2<>'' then node1.AddChild('leadtitle',1).NodeValue:=ftpPath+lFileName2;
if lFileName3<>'' then node1.AddChild('linktitle',1).NodeValue:=ftpPath+lFileName3;
node1.AddChild('columnid',3).NodeValue:=strToInt(item);//211; //机关代字ID
node1.AddChild('webid',3).NodeValue:=2;
node1.AddChild('webgroupid',3).NodeValue:=1;
// node1.AddChild('date',2).NodeValue:=SysUtils.DateTimeToStr(date); //可不写
SaveToFile(lTmpPath+'\test.xml'); //保存xml
end;
//上传http
try
Button1Click(nil);
DSBOutfile.Edit;
DSBOutfile.FieldByName('F_STATUS').AsString:='1';
DSBOutfile.Post;
finally
deletefile(lTmpPath+'\test.xml');
end;
DSBOutfile.Next;
end;
DSBOutfile.ApplyUpdates(0);
DSBOutfile.Close;
lslog:=false;
end;
procedure TFAdmin.wjsc(lTmpPath,lFileName: string); // 文件上传
begin
IdFTP1.Host := ftphost;//服务器地址
IdFTP1.Username := ftpuser; //用户名
IdFTP1.Password := ftppwd; //密码
// IdFTP1.BoundPort := 21; //端口号
if not IdFTP1.Connected then
IdFTP1.Connect();
try
IdFTP1.Put(lTmpPath+lFileName,lFileName); //上传文件：参数１：文件路径+文件名，参数二：文件名
IdFTP1.Disconnect;
// deletefile(lTmpPath+lFileName); //删除文件
Memo1.Lines.Add('上传文件成功!_ _OK_'); //要写成日志
wLog('上传文件成功!_ _OK_'+lFileName);
except
Memo1.Lines.Add('上传文件异常!_ _'+title); //要写成日志
wLog('上传文件异常!_ _'+title);
end;
end;
//上传到另一个服务器 20080413gyf
procedure TFAdmin.wjsc2(lTmpPath,lFileName: string); // 文件上传
begin
IdFTP1.Host := ftphost2;//服务器地址
IdFTP1.Username := ftpuser2; //用户名
IdFTP1.Password := ftppwd2; //密码
// IdFTP1.BoundPort := 21; //端口号
if not IdFTP1.Connected then
IdFTP1.Connect();
try
IdFTP1.Put(lTmpPath+lFileName,lFileName); //上传文件2：参数１：文件路径+文件名，参数二：文件名
IdFTP1.Disconnect;
deletefile(lTmpPath+lFileName); //删除文件
Memo1.Lines.Add('上传文件2成功!_ _OK_'); //要写成日志
wLog('上传文件2成功!_ _OK_'+lFileName);
except
Memo1.Lines.Add('上传文件2异常!_ _'+title); //要写成日志
wLog('上传文件2异常!_ _'+title);
end;
end;
procedure TFAdmin.FormCreate(Sender: TObject);
var optionIni: TInifile;
begin
//读ini文件
optionIni := Tinifile.Create(ExtractFilePath(Application.ExeName) + '\OPTION.ini');
lTmpPath := optionIni.ReadString('OPTION', 'lTmpPath','');
httpaddress := optionIni.ReadString('OPTION', 'httpaddress','');
ftphost := optionIni.ReadString('OPTION', 'ftphost','');
ftpuser := optionIni.ReadString('OPTION', 'ftpuser','');
ftppwd := optionIni.ReadString('OPTION', 'password','');
ftphost2 := optionIni.ReadString('OPTION', 'ftphost2','');
ftpuser2 := optionIni.ReadString('OPTION', 'ftpuser2','');
ftppwd2 := optionIni.ReadString('OPTION', 'password2','');
ftpPath := optionIni.ReadString('OPTION', 'ftpPath','');
optionIni.Free;
end;
procedure TFAdmin.Button1Click(Sender: TObject);
var
strm: TMemoryStream;
ls: String;
begin
IdHTTP1.HandleRedirects:=true;
strm := TMemoryStream.Create;
strm.LoadFromFile(lTmpPath+'\test.xml');
try
IdHTTP1.Post(httpaddress, strm);
finally
ls := IdHTTP1.Response.Server + ': ' + IdHTTP1.Response.ResponseText;
strm.Free;
end;
//判断ls返回值是成功还是失败
Memo2.Lines.Add(ls+'_ _'+title); //要写成日志
wLog(ls+'_ _'+title);
//deletefile(lTmpPath+'\test.xml');
end;
procedure TFAdmin.btnStartSendInfoClick(Sender: TObject);
begin
if btnStartSendInfo.Caption = '启动发布信息' then
begin
btnStartSendInfo.Caption := '停止发布信息';
Timer_Send_Msg.Enabled := True;
end
else begin
btnStartSendInfo.Caption := '启动发布信息';
Timer_Send_Msg.Enabled := False;
end;
end;
procedure TFAdmin.Timer_Send_OutfileTimer(Sender: TObject);
begin
if not lslog then
Button2Click(nil);
end;
procedure TFAdmin.btnExitClick(Sender: TObject);
begin
close;
end;
procedure TFAdmin.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
SQLConnection1.Close;
end;
procedure TFAdmin.btnopenDBClick(Sender: TObject);
begin
DSBOutfile.Filtered:=false;
DSBOutfile.Filter:='F_STATUS=0';
DSBOutfile.Filtered:=true;
DSBOutfile.Open;
dsbAFFIX_ISSUANCE.Open;
end;
end.
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -