没必要保存附件到database的吧
{
}
unit ServiceFrm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, RXShell, ExtCtrls, Db, ADODB, Comobj, StdCtrls, Spin, Mask, ComCtrls, FileCtrl, registry, inifiles, SakPOP3, SakMsg
, mail2000, dfsStatusBar, Ping, WSocket, winsock, FtpSrv;
//用户自定义消息
const
WM_USERSHOW = WM_USER + 100; //显示主窗口消息
WM_USERRECEIVE = WM_USER + 200; //收取邮件消息
WM_USerBackupMail = Wm_User + 300; //备份邮件消息
WM_UserWorkFlow = Wm_User + 400; //工作流消息
type
TServiceForm = class(TForm)
RxTrayIcon: TRxTrayIcon;
PopupMenu1: TPopupMenu;
N1: TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
ADOQueryUser: TADOQuery;
ADOServer: TADOConnection;
GroupBox1: TGroupBox;
Label3: TLabel;
Memo: TMemo;
UpDown_Timer: TUpDown;
ADOQueryMailBox: TADOQuery;
ButtonClose: TButton;
ButtonClearLog: TButton;
ButtonSetConnect: TButton;
Label1: TLabel;
MaskEditGap: TMaskEdit;
ButtonSeting: TButton;
TimerReceive: TTimer;
SakPOP: TSakPOP;
SakMsgList: TSakMsgList;
dfsStatusBar: TdfsStatusBar;
ButtonReceiveMail: TButton;
ADOQueryAttachedFiles: TADOQuery;
ADOQueryBackupTask: TADOQuery;
ADOQueryBackupLst: TADOQuery;
ADOQueryBackupMailbox: TADOQuery;
ADOQueryBackupAttachedFiles: TADOQuery;
ADOQueryDelBackupLst: TADOQuery;
ADOQueryDelBackupTask: TADOQuery;
ADOStoredProcMailFilter: TADOStoredProc;
ADOQueryMessageIdLst: TADOQuery;
ADOQueryGwlcspyjk: TADOQuery;
ADOQueryUpdateGwlcspyjk: TADOQuery;
ADOQueryInsertGwlcspyjk: TADOQuery;
ADOQuerygwlck: TADOQuery;
ADOQuerygwk: TADOQuery;
ADOQueryNextGwLc: TADOQuery;
ADOQueryPop3Error: TADOQuery;
TimerPing: TTimer;
PingInternetUrl: TPing;
ADOQueryGwlcjs: TADOQuery;
ADOQueryExistOaPop3Error: TADOQuery;
WSocketListen: TWSocket;
WSocketSend: TWSocket;
FtpServer: TFtpServer;
procedure N3Click(Sender: TObject);
procedure N1Click(Sender: TObject);
procedure RxTrayIconDblClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure UpDown_TimerClick(Sender: TObject; Button: TUDBtnType);
procedure ButtonCloseClick(Sender: TObject);
procedure ButtonClearLogClick(Sender: TObject);
procedure ButtonSetConnectClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure ButtonSetingClick(Sender: TObject);
procedure TimerReceiveTimer(Sender: TObject);
procedure SakPOPBeforeRetrieve(sender: TObject; MsgIndex: Word);
procedure SakPOPAfterRetrieve(Sender: TObject);
procedure SakPOPRetrieveProgress(Sender: TObject; Percent: Word);
procedure ButtonReceiveMailClick(Sender: TObject);
procedure MaskEditGapChange(Sender: TObject);
procedure SakPOPError(Sender: TObject; Error: Integer; Msg: string);
procedure TimerPingTimer(Sender: TObject);
procedure PingInternetUrlDnsLookupDone(Sender: TObject; Error: Word);
procedure PingInternetUrlEchoReply(Sender, Icmp: TObject;
Error: Integer);
procedure ADOQueryMailBoxPostError(DataSet: TDataSet;
E: EDatabaseError; var Action: TDataAction);
procedure ADOQueryAttachedFilesPostError(DataSet: TDataSet;
E: EDatabaseError; var Action: TDataAction);
procedure ADOQueryPop3ErrorPostError(DataSet: TDataSet;
E: EDatabaseError; var Action: TDataAction);
procedure ADOQueryUpdateGwlcspyjkPostError(DataSet: TDataSet;
E: EDatabaseError; var Action: TDataAction);
procedure ADOQueryInsertGwlcspyjkPostError(DataSet: TDataSet;
E: EDatabaseError; var Action: TDataAction);
procedure WSocketListenDataAvailable(Sender: TObject; Error: Word);
private
{ Private declarations }
procedure CloseForm(sender: tobject);
function GetRegistryKey(key, subkey: string): string;
procedure SetRegistryKey(key, subkey, Value: string);
procedure SetIniFile;
procedure GetIniFile;
procedure ReceiveMaill;
procedure UnbindMsg;
procedure BackupMail;
// procedure WorkFlow;
procedure OaIdPop3Error(Foaid, Fhost, ErrorMsg: string); //处理收信错误
// procedure WorkFlowEnd(Foaid, FMsg: string); //处理工作流自动结束
procedure ExecCmd(Cmd: string);
procedure StartServer;
procedure StopServer;
procedure SocketListen;
procedure SocketSend(StrMsg: string);
procedure QueryState; //查询状态
public
{ Public declarations }
//用户自定义消息处理函数
procedure WMUsershow(var Msg: TMessage); message wm_usershow;
procedure WMUserreceive(var Msg: TMessage); message wm_userreceive;
procedure WmUserBackupMail(var Msg: TMessage); message wm_userbackupmail;
// procedure WmUserWorkFlow(var Msg: TMessage); message wm_userworkflow;
end;
var
ServiceForm: TServiceForm;
FServerAddr: TInAddr;
RemoteIp: string;
implementation
uses SetingFrm;
type
THook = function: boolean;
var
Moudle: THandle;
LoadHookDll: Boolean;
DsnString: string; //数据库连接串
TimeerGap: Integer; //自动收取邮件间隔
DefaultAttachmentUrlPreFixInternet: string; //缺省外网链接地址前缀
DefaultAttachmentUrlPreFixIntranet: string; //缺省内网链接地址前缀
DefaultAttachmentSavePath: string; //缺省附件保存目录
PingUrl: string; //网络连接测试链接
IniFileName: string; //配置文件名
OaId: string; //oa用户id
PingSucceed: Boolean;
PingCount: Integer; //ping次数
{$R *.DFM}
//工作流自动处理
{流程自然结束有2种可能：
1、流程到达了该流程的最终点
2、流程到达了该流程的最终角色
}
{
procedure TServiceForm.WorkFlow;
var
GwxhLst, SpjsLst, SpjssjqxLst: TStrings;
i: Integer;
GwOaid: string;
begin
//取审批标志为未审批且超过审批期限的公文
GwxhLst := TStringList.Create; //公文序号列表
SpjsLst := TStringList.Create; //审批角色列表
SpjssjqxLst := TStringList.Create; //审批角色时间期限
Memo.Lines.Add(StringOfChar('*', 80));
Memo.Lines.Add(FormatDateTime('yyyy-mm-dd hh:mm:ss', Now) + ' 开始检查公文...');
Memo.Lines.Add(StringOfChar('*', 80));
try
begin
//取公文库的公文序号列表、审批角色列表、审批时间列表
ADOQueryGwlcspyjk.Active := True;
while not ADOQueryGwlcspyjk.Eof do
begin //开始公文循环
GwxhLst.Add(ADOQueryGwlcspyjk.FieldByName('gwxh').AsString);
SpjsLst.Add(ADOQueryGwlcspyjk.FieldByName('spjs').AsString);
SpjssjqxLst.Add(ADOQueryGwlcspyjk.FieldByName('spjssjqx').AsString);
ADOQueryGwlcspyjk.Next;
end; //结束公文循环
ADOQueryGwlcspyjk.Active := False; //关闭公文数据集
for i := 0 to GwxhLst.Count - 1 do
begin //开始处理公文
//结束当前流程
ADOQueryUpdateGwlcspyjk.Active := False;
ADOQueryUpdateGwlcspyjk.Parameters.ParamByName('spyj').Value := '因该公文在本流程等待处理超过 ' + SpjssjqxLst + ' 小时期限，建恒OA系统自动继续下一流程';
ADOQueryUpdateGwlcspyjk.Parameters.ParamByName('spjg').Value := '审批通过';
ADOQueryUpdateGwlcspyjk.Parameters.ParamByName('spbj').Value := '1';
ADOQueryUpdateGwlcspyjk.Parameters.ParamByName('spsj').Value := Now;
ADOQueryUpdateGwlcspyjk.Parameters.ParamByName('gwxh').Value := GwxhLst;
ADOQueryUpdateGwlcspyjk.Parameters.ParamByName('spjs').Value := SpjsLst;
ADOQueryUpdateGwlcspyjk.ExecSQL;
Memo.Lines.Add('序号为:' + GwxhLst + ' 的公文因在 ' + SpjsLst + ' 处超过处理期限而被系统自动设置为通过审批...');
//判断是否最终角色
ADOQuerygwk.Active := False;
ADOQuerygwk.Parameters.ParamByName('gwxh').Value := GwxhLst;
ADOQuerygwk.Active := True;
//如果不是最终角色，则取该流程的下一角色
GwOaid := ADOQuerygwk.FieldByName('jbr').AsString;
if (ADOQuerygwk.FieldByName('zzspjs').AsString <> SpjsLst) then
begin
ADOQuerygwlck.Active := False;
ADOQuerygwlck.Parameters.ParamByName('gwlch').Value := ADOQuerygwk.FieldByName('gwlch').AsInteger;
ADOQuerygwlck.Parameters.ParamByName('dqlcjs').Value := SpjsLst;
ADOQuerygwlck.Active := True;
ADOQueryNextGwLc.Active := False;
ADOQueryNextGwLc.Parameters.ParamByName('gwlch').Value := ADOQuerygwk.FieldByName('gwlch').AsInteger;
ADOQueryNextGwLc.Parameters.ParamByName('gwlcxh').Value := ADOQuerygwlck.FieldByName('gwlcxh').AsInteger + 1;
ADOQueryNextGwLc.Active := True;
if ADOQueryNextGwLc.FieldByName('dqlcjs').AsString <> '结束流程' then
begin //如果不是结束标志
//开始下一流程
ADOQueryInsertGwlcspyjk.Active := False;
ADOQueryInsertGwlcspyjk.Parameters.ParamByName('gwxh').Value := GwxhLst;
ADOQueryInsertGwlcspyjk.Parameters.ParamByName('spjs').Value := ADOQueryNextGwLc.FieldByName('dqlcjs').AsString;
ADOQueryInsertGwlcspyjk.Parameters.ParamByName('ddsj').Value := Now;
ADOQueryInsertGwlcspyjk.Parameters.ParamByName('spjssjqx').Value := ADOQueryNextGwLc.FieldByName('dqjcsjqx').AsInteger;
ADOQueryInsertGwlcspyjk.ExecSQL; //插入记录
Memo.Lines.Add('序号为:' + GwxhLst + ' 的公文自动进入一下流程被提交给 ' + ADOQueryNextGwLc.FieldByName('dqlcjs').AsString + ' 审批...');
end
else
begin
//提醒用户他所提交的公文已经审批结束，请他查看审批结果
ADOQueryGwlcjs.Active := False;
ADOQueryGwlcjs.Parameters.ParamByName('gwxh').Value := GwxhLst;
ADOQueryGwlcjs.Parameters.ParamByName('gwlcjs').Value := '1';
ADOQueryGwlcjs.ExecSQL;
WorkFlowEnd(GwOaid, '序号为:' + GwxhLst + ' 的公文自动结束其公文流程...');
end;
ADOQuerygwlck.Active := False;
ADOQueryNextGwLc.Active := False;
end;
ADOQuerygwk.Active := False;
end; //结束处理公文
Memo.Lines.Add('共有 ' + IntToStr(GwxhLst.Count) + ' 封公文被建恒办公自动化系统自动处理...');
end;
finally
begin
//释放字符串列表
GwxhLst.Free;
SpjsLst.Free;
SpjssjqxLst.Free;
end;
end;
Memo.Lines.Add(StringOfChar('*', 80));
Memo.Lines.Add(FormatDateTime('yyyy-mm-dd hh:mm:ss', Now) + ' 结束检查公文...');
Memo.Lines.Add(StringOfChar('*', 80));
end;
}
function atoi(value: string): Integer;
var
i: Integer;
begin
Result := 0;
i := 1;
while (i <= Length(Value)) and (Value = ' ') do
i := i + 1;
while (i <= Length(Value)) and (Value in ['0'..'9']) do begin
Result := Result * 10 + ord(Value) - ord('0');
i := i + 1;
end;
end;
//拆分邮件内容
procedure tserviceform.UnbindMsg;
var
i, j: Integer;
Msg: TSakMsg;
FileName, FileUrlInternet, FileurlIntranet, Priority: string;
TextEncoding, AttachedFiles: string;
NewMailSeq: Integer;
MessageIdLst: TStrings;
begin
//取该用户旧邮件列表
MessageIdLst := TStringList.Create;
ADOQueryMessageIdLst.Active := False;
ADOQueryMessageIdLst.Parameters.ParamByName('foaid').Value := OaId;
ADOQueryMessageIdLst.Active := True;
while not ADOQueryMessageIdLst.Eof do
begin
MessageIdLst.Add(ADOQueryMessageIdLst.FieldByName('fmessageid').AsString);
ADOQueryMessageIdLst.Next;
end;
ADOQueryMessageIdLst.Active := False;
//分解邮件，保存到数据库
for i := 0 to SakMsgList.Count - 1 do
begin
{ 邮件结构，from sakemail组件的sakmsg组件的类声明
FPriority: TPriority;
FUserName: string;
FFrom: string;
FSender: String;
FMessageId: string;
FInReplyTo: string;
FReturnPath: string;
FReplyTo: string;
FSendTo: string;
FCC: string;
FBCC: string;
FDate: string;
FSubject: string;
FText: TStringList;
FExtraHeaders: TStringList;
FAttachedFiles: TAttachedFiles;
FContentType: string;
FContentTransferEncoding: string;
FHeaders: TStringList;
FCharSet: string;
FSizeInBytes: integer;
FUIDL: string;
FRawMail: TStringList;
FClearRawMailAfterParse: boolean;
FTextEncoding: TTextEncoding;
FXMailer: string;
}
//如果新邮件
if MessageIdLst.IndexOf(SakMsgList.Items.MessageId) = -1 then
begin
Msg := SakMsgList.Items; //取邮件
//邮件优先级
case Msg.Priority of
prHighest: Priority := 'PrHighest';
prHigh: Priority := 'PrHigh';
prNormal: Priority := 'PrNormal';
prLow: Priority := 'PrLow';
prLowest: Priority := 'Prlowest';
end;
ADOQueryMailBox.Active := False;
ADOQueryMailBox.Parameters.ParamByName('FOaid').Value := OaId;
ADOQueryMailBox.Parameters.ParamByName('Fpriority').Value := Priority;
ADOQueryMailBox.Parameters.ParamByName('FUserName').Value := Msg.UserName;
ADOQueryMailBox.Parameters.ParamByName('FFrom').Value := Msg.From;
ADOQueryMailBox.Parameters.ParamByName('FSender').Value := Msg.Sender;
ADOQueryMailBox.Parameters.ParamByName('FMessageId').Value := Msg.MessageId;
ADOQueryMailBox.Parameters.ParamByName('FInReplyTo').Value := Msg.InReplyTo;
ADOQueryMailBox.Parameters.ParamByName('FReturnPath').Value := Msg.ReturnPath;
ADOQueryMailBox.Parameters.ParamByName('FReplyTo').Value := Msg.ReplyTo;
ADOQueryMailBox.Parameters.ParamByName('FSendTo').Value := Msg.SendTo;
ADOQueryMailBox.Parameters.ParamByName('FCC').Value := Msg.CC;
ADOQueryMailBox.Parameters.ParamByName('FBCC').Value := Msg.BCC;
ADOQueryMailBox.Parameters.ParamByName('FDate').Value := FormatDateTime('yyyy-mm-dd hh:mm:ss', Now);
ADOQueryMailBox.Parameters.ParamByName('FSubject').Value := Msg.Subject;
ADOQueryMailBox.Parameters.ParamByName('FText').Value := Msg.Text.Text;
ADOQueryMailBox.Parameters.ParamByName('FExtraHeaders').Value := Msg.ExtraHeaders.Text;
if Msg.AttachedFiles.Count > 0 then
AttachedFiles := '0' //如果有附件
else
AttachedFiles := '1'; //如果没有附件
ADOQueryMailBox.Parameters.ParamByName('FAttachedFiles').Value := AttachedFiles;
ADOQueryMailBox.Parameters.ParamByName('FContentType').Value := Msg.ContentType;
ADOQueryMailBox.Parameters.ParamByName('FContentTransferEncoding').value := Msg.ContentTransferEncoding;
ADOQueryMailBox.Parameters.ParamByName('FHeaders').Value := Msg.Headers.Text;
ADOQueryMailBox.Parameters.ParamByName('FCharSet').Value := Msg.CharSet;
ADOQueryMailBox.Parameters.ParamByName('FSizeInBytes').Value := Msg.SizeInBytes;
ADOQueryMailBox.Parameters.ParamByName('FUIDL').Value := Msg.UIDL;
ADOQueryMailBox.Parameters.ParamByName('FRawMail').Value := Msg.RawMail.Text;
if Msg.ClearRawMailAfterParse then
ADOQueryMailBox.Parameters.ParamByName('FClearRawMailAfterParse').Value := '0'
else
ADOQueryMailBox.Parameters.ParamByName('FClearRawMailAfterParse').Value := '1';
//文字解码
case Msg.TextEncoding of
te8Bit: TextEncoding := 'te8bit';
teBase64: TextEncoding := 'teBase64';
end;
ADOQueryMailBox.Parameters.ParamByName('FTextEncoding').Value := TextEncoding;
ADOQueryMailBox.Parameters.ParamByName('FXMailer').Value := Msg.XMailer;
ADOQueryMailBox.Active := True; //保存更改
//取最后增加的邮件id
NewMailSeq := ADOQueryMailBox.FieldByName('NewMailSeq').AsInteger;
if Msg.AttachedFiles.Count > 0 then //保存附件
for j := 0 to Msg.AttachedFiles.Count - 1 do
begin
//生成文件名,以时间和附件名组合
FileName := OaId + '/Cur/' + FormatDateTime('yyyymmddhhmmss', Now) + Msg.AttachedFiles.Items[j].FileName;
//生成链接文件名,在生成的时候把'/'替换成'/'
FileUrlInternet := DefaultAttachmentUrlPreFixInternet + StringReplace(FileName, '/', '/', [rfReplaceAll]);
FileUrlIntranet := DefaultAttachmentUrlPreFixIntranet + StringReplace(FileName, '/', '/', [rfReplaceAll]);
//生成绝对路径文件名
FileName := DefaultAttachmentSavePath + FileName;
//如果该用户保存附件目录不存在，则建立该目录
if not DirectoryExists(DefaultAttachmentSavePath + OaId + '/Cur') then
ForceDirectories(DefaultAttachmentSavePath + OaId + '/Cur');
Msg.AttachedFiles.Items[j].SaveToFile(FileName);
//把结果写到记录集中
ADOQueryAttachedFiles.Parameters.ParamByName('mailseq').Value := NewMailSeq;
ADOQueryAttachedFiles.Parameters.ParamByName('attchedfilename').Value := FileName;
ADOQueryAttachedFiles.Parameters.parambyname('attchedfileurlinternet').Value := FileUrlInternet;
ADOQueryAttachedFiles.Parameters.parambyname('attchedfileurlintranet').Value := FileUrlIntranet;
ADOQueryAttachedFiles.ExecSQL;
end;
end;
end;
MessageIdLst.Free; //释放用户旧邮件列表
end;
procedure tserviceform.ReceiveMaill;
var
i: Integer;
label NextUser; //下一用户，2002-05-29修改
begin
//收取邮件
begin
//如果已经连接服务器，则中断连接
if SakPOP.Connected then SakPOP.Disconnect;
//取用户列表，然后用循环来收取邮件
ADOQueryUser.Active := True;
ADOQueryUser.First;
Memo.Lines.Add(StringOfChar('*', 80));
Memo.Lines.Add(FormatDateTime('yyyy-mm-dd hh:mm:ss', Now) + ' 开始检查邮件...');
Memo.Lines.Add(StringOfChar('*', 80));
while not ADOQueryUser.Eof do
begin
//设置pop3连接参数
SakPOP.Host := Trim(ADOQueryUser.FieldByName('fhost').AsString);
SakPOP.UserId := Trim(ADOQueryUser.FieldByName('fuserid').AsString);
SakPOP.UserPasswd := Trim(ADOQueryUser.FieldByName('fuserpasswd').AsString);
SakPOP.Port := Trim(ADOQueryUser.FieldByName('fport').AsString);
OaId := Trim(ADOQueryUser.FieldByName('foaid').AsString); //取oaid，以决定存放目录
SakPOP.connect; //连接pop3服务器
if SakPOP.POPError then
begin
Memo.Lines.add('Connect Failed. Maybe the server is down or not responding.');
OaIdPop3Error(OaId, SakPOP.Host, 'Connect Failed. Maybe the server is down or not responding.');
goto NextUser; //下一用户，2002-05-29修改
end;
if not SakPOP.login then
begin
Memo.Lines.add('Unauthorized Access...');
OaIdPop3Error(OaId, SakPOP.Host, 'Unauthorized Access...');
goto Nextuser; //下一用户，2002-05-29修改
end;
SakPOP.Init;
Memo.Lines.Add(oaid + ' Receive ' + intToStr(SakPOP.NewMsgsCount) + ' New Msg(s) of ' + intToStr(SakPOP.MsgsCount));
SakPOP.RetrieveAllMessages(SakMsgList);
//如果该用户在oa中设置为不保留邮件('1')的话，则删除邮件
if ADOQueryUser.FieldByName('Fkeepbackup').AsString = '1' then
for i := 1 to SakPOP.MsgsCount do
SakPOP.DeleteMessage(i); //删除邮件
//断开邮件服务器连接
SakPOP.Disconnect;
if SakMsgList.Count > 0 then //如果有邮件，则分解附件成单独内容
begin
UnbindMsg; //把邮件分解成内容
//如果有新邮件则执行存储过程进行邮件过滤
Memo.Lines.Add(FormatDateTime('yyyy-mm-dd hh:mm:ss', Now) + ' 开始检查邮件过滤器...');
ADOStoredProcMailFilter.Active := False;
ADOStoredProcMailFilter.Parameters.ParamByName('oaid').Value := OaId;
ADOStoredProcMailFilter.ExecProc;
Memo.Lines.Add(FormatDateTime('yyyy-mm-dd hh:mm:ss', Now) + ' 结束检查邮件过滤器...');
end;
Nextuser:
ADOQueryUser.Next; //下一oa用户
end;
//断开数据库连接
ADOQueryUser.Active := False;
Memo.Lines.Add(StringOfChar('*', 80));
Memo.Lines.Add(FormatDateTime('yyyy-mm-dd hh:mm:ss', Now) + ' 结束检查邮件... ');
Memo.Lines.Add(StringOfChar('*', 80));
end;
end;
//取INI文件配置
procedure tserviceform.GetIniFile;
var
ini: TIniFile;
begin
ini := TIniFile.Create(IniFileName);
try
TimeerGap := ini.ReadInteger('MailService', 'TimeerGap', 5);
DefaultAttachmentUrlPreFixInternet := ini.ReadString('MailService', 'DefaultAttachmentUrlPreFixInternet', '');
DefaultAttachmentUrlPreFixIntranet := ini.ReadString('MailService', 'DefaultAttachmentUrlPreFixIntranet', '');
DefaultAttachmentSavePath := ini.ReadString('MailService', 'DefaultAttachmentSavePath', '');
PingUrl := ini.ReadString('MailService', 'PingUrl', 'www.sina.com.cn');
UpDown_Timer.Position := TimeerGap;
TimerReceive.Interval := TimeerGap * 60 * 1000;
TimerReceive.Enabled := True;
finally
ini.Free;
end;
end;
//写ini文件
procedure tserviceform.SetIniFile;
var
ini: TIniFile;
begin
ini := TIniFile.Create(IniFileName);
try
ini.WriteInteger('MailService', 'TimeerGap', TimeerGap); //时间间隔
ini.WriteString('MailService', 'DefaultAttachmentUrlPreFixInternet', DefaultAttachmentUrlPreFixInternet);
ini.WriteString('MailService', 'DefaultAttachmentUrlPreFixIntranet', DefaultAttachmentUrlPreFixIntranet);
ini.WriteString('MailService', 'DefaultAttachmentSavePath', DefaultAttachmentSavePath); //缺省保存路径
ini.WriteString('MailService', 'PingUrl', PingUrl);
finally
ini.Free;
end;
end;
//读注册表键值
function tserviceform.GetRegistryKey(key, subkey: string): string;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
with Reg do
begin
RootKey := HKEY_LOCAL_MACHINE;
if OpenKey('SOFTWARE/MailService/' + key, false) then
Result := ReadString(subkey)
else
Result := '';
CloseKey;
end;
Reg.Free;
end;
//写注册表键值
procedure tserviceform.SetRegistryKey(key, subkey, Value: string);
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
with Reg do
begin
RootKey := HKEY_LOCAL_MACHINE;
if OpenKey('SOFTWARE/MailService/' + key, True) then
WriteString(Subkey, Value);
CloseKey;
end;
Reg.Free;
end;
procedure tserviceform.WMUsershow(var Msg: TMessage);
begin
Show;
end;
//Wm_UserRective消息
procedure TServiceForm.WMUserreceive(var Msg: TMessage);
begin
// 开始收取邮件
try
try
ADOServer.Connected := True;
PingCount := 0;
PingSucceed := False;
TimerPing.Enabled := True; ;
except
on e: Exception do
begin
Memo.Lines.Add(StringOfChar('*', 80));
Memo.Lines.Add(FormatDateTime('yyyy-mm-dd hh:mm:ss', Now) + e.Message);
Memo.Lines.Add(StringOfChar('*', 80));
end;
end;
finally
ADOServer.Connected := False;
end;
end;
procedure tserviceform.closeform(sender: tobject);
begin
ServiceForm.Close;
end;
//退出系统
procedure TServiceForm.N3Click(Sender: TObject);
var
PFunc: TFarProc;
begin
if Application.MessageBox('关闭本程序将关闭邮件服务功能，是否关闭?', '提示信息', MB_ICONQUESTION + MB_YESNO) = idyes then
begin
if loadhookdll then
begin
Pfunc := GetProcAddress(Moudle, 'DisableHotKeyHook');
thook(pfunc);
Freelibrary(Moudle);
end;
Application.Terminate;
end;
end;
procedure TServiceForm.N1Click(Sender: TObject);
begin
RxTrayIconDblClick(Self);
end;
procedure TServiceForm.RxTrayIconDblClick(Sender: TObject);
begin
ShowWindow(handle, sw_ShowNormal);
SetForegroundWindow(handle);
show;
end;
//建立窗体
procedure TServiceForm.FormCreate(Sender: TObject);
var
PFunc: TFarProc;
begin
//加载动态库
Moudle := Loadlibrary(PChar(ExtractFilePath(Application.ExeName) + 'KEYHOOK.DLL'));
if Moudle > 32 then
begin //加载动态库成功
loadhookdll := True;
RxTrayIcon.Hint := '邮件服务-热键(CTRL+S)激活状态';
Pfunc := GetProcAddress(Moudle, 'EnableHotKeyHook');
thook(pfunc);
end
else //加载失败
begin
RxTrayIcon.Hint := '邮件服务-普通状态';
loadhookdll := False;
end;
Application.OnMinimize := closeform;
//检测Log目录是否存在,如果不存在则建立该目录
if not DirectoryExists(ExtractFilePath(Application.ExeName) + 'Log') then
ForceDirectories(ExtractFilePath(Application.ExeName) + 'Log');
//取dsn连接字符串
DsnString := GetRegistryKey('Dsn', 'DsnString');
ADOServer.ConnectionString := DsnString;
//
SetWindowLong(MaskEditGap.Handle, GWL_STYLE, GetWindowLong(MaskEditGap.Handle, GWL_STYLE) or ES_NUMBER);
IniFileName := ExtractFilePath(Application.ExeName) + 'MailService.Ini';
Getinifile;
//判断附件存放目录是否存在，如果不存在则建立该目录
if DefaultAttachmentSavePath <> '' then
begin
//判断目录是否以'/'结尾，如果否则自动加上'/'
if DefaultAttachmentSavePath[Length(DefaultAttachmentSavePath)] <> '/' then
DefaultAttachmentSavePath := DefaultAttachmentSavePath + '/';
//检查目录
if not DirectoryExists(Copy(DefaultAttachmentSavePath, 1, Length(DefaultAttachmentSavePath) - 1)) then
ForceDirectories(Copy(DefaultAttachmentSavePath, 1, Length(DefaultAttachmentSavePath) - 1));
end;
SocketListen;
end;
procedure TServiceForm.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Action := caNone;
ShowWindow(handle, sw_Hide);
end;
//检查时间间隔发生改变时
procedure TServiceForm.UpDown_TimerClick(Sender: TObject; Button: TUDBtnType);
begin
TimeerGap := UpDown_Timer.Position;
TimerReceive.Enabled := False;
TimerReceive.Interval := UpDown_Timer.Position * 60 * 1000;
//保存配置
Setinifile;
TimerReceive.Enabled := True;
end;
procedure TServiceForm.ButtonCloseClick(Sender: TObject);
begin
Close;
end;
//清除邮件系统日志
procedure TServiceForm.ButtonClearLogClick(Sender: TObject);
var
Result: Integer;
begin
Result := Application.MessageBox('在清除邮件服务日志之前是否要保存"邮件服务日志"', '提示信息', MB_ICONQUESTION or MB_YESNOCANCEL);
case Result of
idyes:
with TSaveDialog.Create(Self) do
begin
Title := '保存邮件服务日志';
DefaultExt := 'Log';
Filter := '日志文件(*.Log)|*.Log|文本文件(*.Txt)|*.Txt|所有文件(*.*)|*.*';
InitialDir := ExtractFilePath(Application.ExeName) + 'Log';
if Execute then Memo.Lines.SaveToFile(FileName);
Memo.Lines.Clear;
end;
idno: Memo.Lines.Clear;
IDCANCEL: Exit;
end;
end;
//设置数据库连接
procedure TServiceForm.ButtonSetConnectClick(Sender: TObject);
begin
DsnString := PromptDataSource(Handle, DsnString);
ADOServer.ConnectionString := DsnString;
SetRegistryKey('Dsn', 'DsnString', DsnString);
end;
//检查数据库连接是否配置
procedure TServiceForm.FormShow(Sender: TObject);
begin
if DsnString = '' then
if Application.MessageBox('数据库连接没有配置，是否现在进行配置?', '配置连接串', MB_ICONQUESTION or MB_YESNO) = idyes then
ButtonSetConnectClick(Self);
end;
//系统设置
procedure TServiceForm.ButtonSetingClick(Sender: TObject);
begin
//设置缺省目录、文件前缀等
FormSeting.EditDefaultAttachmentUrlPreFixInternet.Text := DefaultAttachmentUrlPreFixInternet;
FormSeting.EditDefaultAttachmentUrlPreFixIntranet.Text := DefaultAttachmentUrlPreFixIntranet;
FormSeting.DirectoryEditDefaultAttachmentSavePath.Text := DefaultAttachmentSavePath;
if formseting.ShowModal = mrok then
begin
DefaultAttachmentUrlPreFixInternet := FormSeting.EditDefaultAttachmentUrlPreFixInternet.Text;
DefaultAttachmentUrlPreFixIntranet := FormSeting.EditDefaultAttachmentUrlPreFixIntranet.Text;
DefaultAttachmentSavePath := FormSeting.DirectoryEditDefaultAttachmentSavePath.Text;
PingUrl := FormSeting.EditPingUrl.Text;
//判断后缀是否为'/'，如果否则自动加上'/'
if DefaultAttachmentUrlPreFixInternet[Length(DefaultAttachmentUrlPreFixInternet)] <> '/' then
DefaultAttachmentUrlPreFixInternet := DefaultAttachmentUrlPreFixInternet + '/';
//判断后缀是否为'/'，如果否则自动加上'/'
if DefaultAttachmentUrlPreFixIntranet[Length(DefaultAttachmentUrlPreFixIntranet)] <> '/' then
DefaultAttachmentUrlPreFixIntranet := DefaultAttachmentUrlPreFixIntranet + '/';
//判断目录是否为'/'，如果否则自动加上'/'
if DefaultAttachmentSavePath[Length(DefaultAttachmentSavePath)] <> '/' then
DefaultAttachmentSavePath := DefaultAttachmentSavePath + '/';
if not DirectoryExists(Copy(DefaultAttachmentSavePath, 1, Length(DefaultAttachmentSavePath) - 1)) then
ForceDirectories(Copy(DefaultAttachmentSavePath, 1, Length(DefaultAttachmentSavePath) - 1));
Setinifile; //保存配置
end;
end;
//定时器事件
procedure TServiceForm.TimerReceiveTimer(Sender: TObject);
begin
//定时收取邮件
//停止计时
TimerReceive.Enabled := False;
//连接
ADOServer.Connected := True;
try
try
begin
//工作流自动处理
// WorkFlow;
//收取邮件
PingCount := 0;
PingSucceed := False;
TimerPing.Enabled := True; ;
//备份邮件
BackupMail;
end;
except
on e: Exception do
begin
Memo.Lines.Add(StringOfChar('*', 80));
Memo.Lines.Add(FormatDateTime('yyyy-mm-dd hh:mm:ss', Now) + e.message);
Memo.Lines.Add(StringOfChar('*', 80));
end;
end;
//断开
finally
begin
ADOServer.Connected := False;
//恢复计时
TimerReceive.Enabled := True;
end;
end;
end;
procedure TServiceForm.SakPOPBeforeRetrieve(sender: TObject;
MsgIndex: Word);
begin
dfsStatusBar.Panels[2].Enabled := True;
dfsStatusBar.Panels[1].Text := '正在收取 ' + oaid + ' 邮件...';
dfsStatusBar.Panels[2].GaugeAttrs.Position := 0;
end;
procedure TServiceForm.SakPOPAfterRetrieve(Sender: TObject);
begin
dfsStatusBar.Panels[2].Enabled := False;
dfsStatusBar.Panels[1].Text := '收取 ' + OaId + ' 邮件结束...';
end;
procedure TServiceForm.SakPOPRetrieveProgress(Sender: TObject;
Percent: Word);
begin
dfsStatusBar.Panels[2].GaugeAttrs.Position := Percent;
end;
//收取邮件
procedure TServiceForm.ButtonReceiveMailClick(Sender: TObject);
begin
//收取邮件
TimerReceive.Enabled := False; //停止计时
try
try
begin
// 连接
ADOServer.Connected := True;
//工作流自动处理
// WorkFlow;
//收取邮件
PingCount := 0;
PingSucceed := False;
TimerPing.Enabled := True; ;
//备份邮件
BackupMail;
end;
except
on e: Exception do
begin
Memo.Lines.Add(StringOfChar('*', 80));
Memo.Lines.Add(FormatDateTime('yyyy-mm-dd hh:mm:ss', Now) + e.Message);
Memo.Lines.Add(StringOfChar('*', 80));
end;
end;
//断开
finally
begin
ADOServer.Connected := False;
TimerReceive.Enabled := True; //恢复计时
end;
end;
//计时值改变
end;
procedure TServiceForm.MaskEditGapChange(Sender: TObject);
begin
TimerReceive.Enabled := False; //停止计时
TimerReceive.Interval := StrToInt(MaskEditGap.Text) * 60 * 1000;
//保存配置
Setinifile;
TimerReceive.Enabled := True; //恢复计时
end;
procedure TServiceForm.SakPOPError(Sender: TObject; Error: Integer;
Msg: string);
begin
//处理Pop错误
Memo.Lines.Add('错误号: ' + IntToStr(Error) + ' 错误信息: ' + Msg);
end;
//备份邮件
//邮件备份
procedure TServiceForm.BackupMail;
var
MailSeq: Integer;
MailMessage: TMailMessage2000;
OaId: string;
AttachedFileName: string;
TmpLst: TStrings;
Directory: string;
Contenttype: string;
Loop: Integer;
begin
//备份邮件
Memo.Lines.Add(StringOfChar('*', 80));
Memo.Lines.Add(FormatDateTime('yyyy-mm-dd hh:mm:ss', Now) + ' 开始检查邮件备份...');
Memo.Lines.Add(StringOfChar('*', 80));
ADOQueryBackupTask.Active := True;
//取备份任务
while not ADOQueryBackupTask.Eof do
begin
OaId := ADOQueryBackupTask.FieldByName('oaid').AsString;
Directory := ADOQueryBackupTask.FieldByName('backupdirectory').AsString;
//如果目录不存在，则建立备份目录
if Directory[Length(Directory)] <> '/' then
Directory := Directory + '/';
if not DirectoryExists(Copy(Directory, 1, Length(Directory) - 1)) then
ForceDirectories(Copy(Directory, 1, Length(Directory) - 1));
ADOQueryBackupLst.Active := False;
ADOQueryBackupLst.Parameters.ParamByName('foaid').Value := OaId;
ADOQueryBackupLst.Active := True;
Memo.Lines.Add(FormatDateTime('yyyy-mm-dd hh:mm:ss', Now) + ' 开始检查 ' + OaId + ' 的邮件备份...');
while not ADOQueryBackupLst.Eof do
begin
//取该oa用户要备份的邮件mailseq
MailSeq := AdoQueryBackupLst.FieldByName('mailseq').AsInteger;
ADOQueryBackupMailbox.Active := False;
ADOQueryBackupMailbox.Parameters.ParamByName('mailseq').Value := MailSeq;
ADOQueryBackupMailbox.Active := True;
TmpLst := TStringList.Create;
//取邮件列表
while not ADOQueryBackupMailbox.Eof do
begin
MailMessage := TMailMessage2000.Create(nil);
//生成邮件头
MailMessage.SetFrom(ADOQueryBackupMailbox.FieldByName('ffrom').AsString, '');
MailMessage.SetReplyTo(ADOQueryBackupMailbox.FieldByName('freplyto').AsString, '');
MailMessage.Subject := ADOQueryBackupMailbox.FieldByName('fsubject').AsString;
//没办法处理时间格式，只能用当前时间来代替
MailMessage.Date := StrToDateTime(ADOQueryBackupMailbox.FieldByName('fdate').AsString);
MailMessage.AddTo(ADOQueryBackupMailbox.FieldByName('fsendto').AsString, '');
MailMessage.AddCc(ADOQueryBackupMailbox.FieldByName('fcc').AsString, '');
MailMessage.AddBcc(ADOQueryBackupMailbox.FieldByName('fbcc').AsString, '');
//字符集强制使用中文
MailMessage.Charset := 'GB2312';
//使用邮件自己的字符集
//MailMessage.Charset:=AdoQueryMailBox.FieldByName('fcharset').AsString;
//生成邮件体
Contenttype := ADOQueryBackupMailbox.FieldByName('fcontenttype').AsString;
TmpLst.Text := ADOQueryBackupMailbox.FieldByName('ftext').Value;
if Pos('TEXT/HTML', Contenttype) = 0 then
//当作html邮件
MailMessage.SetTextHTML(TmpLst)
else
//当作text邮件
MailMessage.SetTextPlain(TmpLst);
//如果有附件
if ADOQueryBackupMailbox.FieldByName('fattachedfiles').AsString = '0' then
begin
//生成附件表
ADOQueryBackupAttachedFiles.Active := False;
ADOQueryBackupAttachedFiles.Parameters.ParamByName('mailseq').Value := MailSeq;
ADOQueryBackupAttachedFiles.Active := True;
//生成邮件附件部分
while not ADOQueryBackupAttachedFiles.Eof do
begin
AttachedFileName := ADOQueryBackupAttachedFiles.FieldByName('attchedfilename').AsString;
//如果附件是存在的,则生成Message附件
if FileExists(AttachedFileName) then
begin
//增加附件
MailMessage.AttachFile(AttachedFileName);
//解码
for Loop := 0 to MailMessage.AttachList.Count - 1 do
if MailMessage.AttachList[Loop].Decoded.Size = 0 then
MailMessage.AttachList[Loop].Decode;
end;
ADOQueryBackupAttachedFiles.Next;
end;
ADOQueryBackupAttachedFiles.Active := False;
//增加附件后重新生成body
MailMessage.RebuildBody;
end;
MailMessage.SaveToFile(Directory + FormatDateTime('yyyymmddhhmmss', Now) + '.eml');
MailMessage.Free;
ADOQueryBackupMailbox.Next;
end;
ADOQueryBackupMailbox.Active := False;
TmpLst.Free;
Memo.Lines.Add(FormatDateTime('yyyy-mm-dd hh:mm:ss', Now) + ' 结束检查 ' + OaId + ' 的邮件备份...');
ADOQueryBackupLst.Next;
end;
ADOQueryBackupLst.Active := False;
//删除备份邮件列表
ADOQueryDelBackupLst.Active := False;
ADOQueryDelBackupLst.Parameters.ParamByName('oaid').Value := OaId;
ADOQueryDelBackupLst.ExecSQL;
//标志该备份任务是否已完成
ADOQueryBackupTask.Edit;
ADOQueryBackupTask.FieldByName('Flag').Value := '0';
ADOQueryBackupTask.Post;
ADOQueryBackupTask.Next;
end;
ADOQueryBackupTask.Active := False;
//删除备份任务中已经进行过备份的任务
ADOQueryDelBackupTask.Active := False;
ADOQueryDelBackupTask.Parameters.ParamByName('flag').Value := '0';
ADOQueryDelBackupTask.ExecSQL;
Memo.Lines.Add(StringOfChar('*', 80));
Memo.Lines.Add(FormatDateTime('yyyy-mm-dd hh:mm:ss', Now) + ' 结束检查邮件备份... ');
Memo.Lines.Add(StringOfChar('*', 80));
end;
//备份邮件消息
procedure TServiceForm.WmUserBackupMail(var Msg: TMessage);
begin
try
try
ADOServer.Connected := True; //连接
BackupMail; //备份邮件
except
on e: Exception do
begin
Memo.Lines.Add(StringOfChar('*', 80));
Memo.Lines.Add(FormatDateTime('yyyy-mm-dd hh:mm:ss', Now) + e.Message);
Memo.Lines.Add(StringOfChar('*', 80));
end;
end;
finally
ADOServer.Connected := False; //断开
end;
end;
//工作流消息
{
procedure TServiceForm.WmUserWorkFlow(var Msg: TMessage);
begin
try
try
ADOServer.Connected := True; //连接
//WorkFlow; //处理工作流 s
except
on e: Exception do
begin
Memo.Lines.Add(StringOfChar('*', 80));
Memo.Lines.Add(FormatDateTime('yyyy-mm-dd hh:mm:ss', Now) + e.Message);
Memo.Lines.Add(StringOfChar('*', 80));
end;
end;
finally
ADOServer.Connected := False; //断开
end;
end;
}
procedure TServiceForm.OaIdPop3Error(Foaid, Fhost, ErrorMsg: string);
var
ErrorLst: TStrings;
begin
//检查是否有必要发邮件
ADOQueryExistOaPop3Error.Active := False;
ADOQueryExistOaPop3Error.Parameters.ParamByName('foaid').Value := Foaid;
ADOQueryExistOaPop3Error.Parameters.ParamByName('fmailflag').Value := 0;
ADOQueryExistOaPop3Error.Parameters.ParamByName('fsubject').Value := '系统管理员的来信:你的Pop3用户设置可能有错误';
ADOQueryExistOaPop3Error.Active := True;
//如果没有系统管理员的Pop3错误信息邮件，则发送邮件给用户
if ADOQueryExistOaPop3Error.FieldByName('existoapop3error').AsInteger = 0 then
begin
//处理错误信息
ErrorLst := TStringList.Create;
ErrorLst.Add('这是系统管理员的来信：');
ErrorLst.Add('你设置的服务器地址为: ' + Fhost + ' 的Pop3服务器可能有错误!!');
ErrorLst.Add('错误信息如下:' + ErrorMsg);
ErrorLst.Add('请用户自觉修改自己的Pop3设置，以保证OA系统的正常运行');
ErrorLst.Add('From:系统管理员');
ErrorLst.Add('时间:' + FormatDateTime('yyyy-mm-dd hh:mm:ss am/pm', Now));
ADOQueryPop3Error.Active := False;
ADOQueryPop3Error.Parameters.ParamByName('foaid').Value := Foaid;
ADOQueryPop3Error.Parameters.ParamByName('ffrom').Value := '系统管理员';
ADOQueryPop3Error.Parameters.ParamByName('fsendto').Value := Foaid;
ADOQueryPop3Error.Parameters.ParamByName('fdate').Value := FormatDateTime('yyyy-mm-dd hh:mm:ss', Now);
ADOQueryPop3Error.Parameters.ParamByName('fsubject').Value := '系统管理员的来信:你的Pop3用户设置可能有错误';
ADOQueryPop3Error.Parameters.ParamByName('fmailboxid').Value := 1;
ADOQueryPop3Error.Parameters.ParamByName('fmailflag').Value := 0;
ADOQueryPop3Error.Parameters.ParamByName('ftext').Value := ErrorLst.Text;
ADOQueryPop3Error.ExecSQL;
ErrorLst.Free;
end;
ADOQueryExistOaPop3Error.Active := False;
end;
procedure TServiceForm.TimerPingTimer(Sender: TObject);
begin
//测试网络连接，如果三次还不能正确连接指定Url，则不收取邮件
TimerPing.Enabled := False;
if PingCount < 3 then //ping次数小于3
begin
if PingSucceed then
begin
//收取邮件
ReceiveMaill;
Exit;
end
else
PingInternetUrl.DnsLookup(PingUrl);
end;
end;
procedure TServiceForm.PingInternetUrlDnsLookupDone(Sender: TObject;
Error: Word);
begin
if Error <> 0 then
begin
Memo.Lines.Add('在连接Internet主机 ' + PingUrl + ' 时失败，请检查网络连接是否正常...');
PingCount := PingCount + 1;
if PingCount >= 3 then
PingSucceed := False;
TimerPing.Enabled := True;
Exit;
end;
Memo.Lines.Add('Internet主机 ''' + PingUrl + ''' 的Ip地址为 ' + PingInternetUrl.DnsResult);
PingInternetUrl.Address := PingInternetUrl.DnsResult;
PingInternetUrl.Ping;
PingSucceed := True;
end;
procedure TServiceForm.PingInternetUrlEchoReply(Sender, Icmp: TObject;
Error: Integer);
begin
if Error = 0 then
begin
Memo.Lines.Add('不能连接Internet主机' + PingInternetUrl.HostIP + '...' + PingInternetUrl.ErrorString);
PingCount := PingCount + 1;
if PingCount > 3 then
PingSucceed := False;
TimerPing.Enabled := True;
end
else
begin
Memo.Lines.Add('Received ' + IntToStr(PingInternetUrl.Reply.DataSize) +
' bytes from ' + PingInternetUrl.HostIP +
' in ' + IntToStr(PingInternetUrl.Reply.RTT) + ' msecs');
PingSucceed := True;
end;
TimerPing.Enabled := True;
end;
procedure TServiceForm.ADOQueryMailBoxPostError(DataSet: TDataSet;
E: EDatabaseError; var Action: TDataAction);
var
AdoErrors: Errors;
AdoError: Error;
iCount: Integer;
begin
AdoErrors := ADOServer.Errors;
Memo.Lines.Add(StringOfChar('*', 80));
for iCount := 0 to AdoErrors.Count - 1 do
begin
AdoError := AdoErrors.Item[icount];
Memo.Lines.Add('Error Number: ' + IntToStr(AdoError.Number));
Memo.Lines.Add('Error Source: ' + AdoError.Source);
Memo.Lines.Add('Error Description: ' + AdoError.Description);
Memo.Lines.Add('Error HelpFile: ' + AdoError.HelpFile);
Memo.Lines.Add('Error SqlState: ' + AdoError.SQLState);
Memo.Lines.Add('Error NativeError: ' + IntToStr(AdoError.NativeError));
end;
Memo.Lines.Add(StringOfChar('*', 80));
end;
procedure TServiceForm.ADOQueryAttachedFilesPostError(DataSet: TDataSet;
E: EDatabaseError; var Action: TDataAction);
var
AdoErrors: Errors;
AdoError: Error;
iCount: Integer;
begin
AdoErrors := ADOServer.Errors;
Memo.Lines.Add(StringOfChar('*', 80));
for iCount := 0 to AdoErrors.Count - 1 do
begin
AdoError := AdoErrors.Item[icount];
Memo.Lines.Add('Error Number: ' + IntToStr(AdoError.Number));
Memo.Lines.Add('Error Source: ' + AdoError.Source);
Memo.Lines.Add('Error Description: ' + AdoError.Description);
Memo.Lines.Add('Error HelpFile: ' + AdoError.HelpFile);
Memo.Lines.Add('Error SqlState: ' + AdoError.SQLState);
Memo.Lines.Add('Error NativeError: ' + IntToStr(AdoError.NativeError));
end;
Memo.Lines.Add(StringOfChar('*', 80));
end;
procedure TServiceForm.ADOQueryPop3ErrorPostError(DataSet: TDataSet;
E: EDatabaseError; var Action: TDataAction);
var
AdoErrors: Errors;
AdoError: Error;
iCount: Integer;
begin
AdoErrors := ADOServer.Errors;
Memo.Lines.Add(StringOfChar('*', 80));
for iCount := 0 to AdoErrors.Count - 1 do
begin
AdoError := AdoErrors.Item[icount];
Memo.Lines.Add('Error Number: ' + IntToStr(AdoError.Number));
Memo.Lines.Add('Error Source: ' + AdoError.Source);
Memo.Lines.Add('Error Description: ' + AdoError.Description);
Memo.Lines.Add('Error HelpFile: ' + AdoError.HelpFile);
Memo.Lines.Add('Error SqlState: ' + AdoError.SQLState);
Memo.Lines.Add('Error NativeError: ' + IntToStr(AdoError.NativeError));
end;
Memo.Lines.Add(StringOfChar('*', 80));
end;
procedure TServiceForm.ADOQueryUpdateGwlcspyjkPostError(DataSet: TDataSet;
E: EDatabaseError; var Action: TDataAction);
var
AdoErrors: Errors;
AdoError: Error;
iCount: Integer;
begin
AdoErrors := ADOServer.Errors;
Memo.Lines.Add(StringOfChar('*', 80));
for iCount := 0 to AdoErrors.Count - 1 do
begin
AdoError := AdoErrors.Item[icount];
Memo.Lines.Add('Error Number: ' + IntToStr(AdoError.Number));
Memo.Lines.Add('Error Source: ' + AdoError.Source);
Memo.Lines.Add('Error Description: ' + AdoError.Description);
Memo.Lines.Add('Error HelpFile: ' + AdoError.HelpFile);
Memo.Lines.Add('Error SqlState: ' + AdoError.SQLState);
Memo.Lines.Add('Error NativeError: ' + IntToStr(AdoError.NativeError));
end;
Memo.Lines.Add(StringOfChar('*', 80));
end;
procedure TServiceForm.ADOQueryInsertGwlcspyjkPostError(DataSet: TDataSet;
E: EDatabaseError; var Action: TDataAction);
var
AdoErrors: Errors;
AdoError: Error;
iCount: Integer;
begin
AdoErrors := ADOServer.Errors;
Memo.Lines.Add(StringOfChar('*', 80));
for iCount := 0 to AdoErrors.Count - 1 do
begin
AdoError := AdoErrors.Item[icount];
Memo.Lines.Add('Error Number: ' + IntToStr(AdoError.Number));
Memo.Lines.Add('Error Source: ' + AdoError.Source);
Memo.Lines.Add('Error Description: ' + AdoError.Description);
Memo.Lines.Add('Error HelpFile: ' + AdoError.HelpFile);
Memo.Lines.Add('Error SqlState: ' + AdoError.SQLState);
Memo.Lines.Add('Error NativeError: ' + IntToStr(AdoError.NativeError));
end;
Memo.Lines.Add(StringOfChar('*', 80));
end;
{
procedure TServiceForm.WorkFlowEnd(Foaid, FMsg: string);
var
MsgLst: TStrings;
begin
//处理错误信息
MsgLst := TStringList.Create;
MsgLst.Add('这是系统管理员的来信：');
MsgLst.Add('你有一封公文因在办公自动化公文系统中超过最大处理期限而被自动通过...');
MsgLst.Add('审批信息如下:' + FMsg);
MsgLst.Add('如果用户对此自动审批意见有异议的话，请与系统管理员或管理部联系....');
MsgLst.Add('From:系统管理员');
MsgLst.Add('时间:' + FormatDateTime('yyyy-mm-dd hh:mm:ss am/pm', Now));
ADOQueryPop3Error.Active := False;
ADOQueryPop3Error.Parameters.ParamByName('foaid').Value := Foaid;
ADOQueryPop3Error.Parameters.ParamByName('ffrom').Value := '系统管理员';
ADOQueryPop3Error.Parameters.ParamByName('fsendto').Value := Foaid;
ADOQueryPop3Error.Parameters.ParamByName('fdate').Value := FormatDateTime('yyyy-mm-dd hh:mm:ss', Now);
ADOQueryPop3Error.Parameters.ParamByName('fsubject').Value := '系统管理员的来信:你有一封公文已被审批通过';
ADOQueryPop3Error.Parameters.ParamByName('fmailboxid').Value := 1;
ADOQueryPop3Error.Parameters.ParamByName('fmailflag').Value := 0;
ADOQueryPop3Error.Parameters.ParamByName('ftext').Value := MsgLst.Text;
ADOQueryPop3Error.ExecSQL;
MsgLst.Free;
end;
}
procedure TServiceForm.ExecCmd(Cmd: string);
begin
//执行命令行
WinExec(PChar(Cmd), SW_HIDE);
end;
procedure TServiceForm.StartServer;
begin
//启动ftp
FtpServer.Start;
end;
procedure TServiceForm.StopServer;
begin
//停止ftp
FtpServer.Stop;
FtpServer.DisconnectAll;
end;
procedure TServiceForm.SocketListen;
begin
//监听
FServerAddr := WSocketResolveHost('0.0.0.0');
if FServerAddr.S_addr = htonl(INADDR_LOOPBACK) then
FServerAddr := WSocketResolveHost(LocalHostName);
WSocketListen.Proto := 'udp';
WSocketListen.Addr := '0.0.0.0';
WSocketListen.Port := '88998';
WSocketListen.Listen;
end;
procedure TServiceForm.WSocketListenDataAvailable(Sender: TObject;
Error: Word);
var
Buffer: array[0..1023] of char;
Len: Integer;
Src: TSockAddrIn;
SrcLen: Integer;
TmpStr, StrCmd: string;
begin
SrcLen := SizeOf(Src);
Len := WSocketListen.ReceiveFrom(@Buffer, SizeOf(Buffer), Src, SrcLen);
if Len >= 0 then
begin
if (FServerAddr.S_addr = INADDR_ANY) or (FServerAddr.S_addr = Src.Sin_addr.S_addr) then
begin
Buffer[Len] := #0;
TmpStr := IntToStr(atoi(TmpStr) + 1) +
' ' + StrPas(inet_ntoa(Src.sin_addr)) +
':' + IntToStr(ntohs(Src.sin_port)) +
'--> ' + StrPas(Buffer);
StrCmd := strpas(Buffer);
// Memo.Lines.Add(TmpStr);
//远程ip，发送状态码时使用
RemoteIp := StrPas(inet_ntoa(Src.sin_addr));
//
if Pos('ftp:', StrCmd) > 0 then
begin
if Copy(StrCmd, 5, Length(StrCmd)) = 'start' then
StartServer
else
StopServer;
end
else
if Pos('cmd:', StrCmd) > 0 then
execcmd(Copy(StrCmd, 5, Length(StrCmd)))
else
if Pos('querystate:', StrCmd) > 0 then
QueryState;
end;
end;
end;
procedure TServiceForm.SocketSend(StrMsg: string);
begin
//发送消息
WSocketSend.Proto := 'udp';
WSocketSend.Port := '88998';
WSocketSend.Localport := '88999';
WSocketsend.Addr := RemoteIp;
WSocketsend.Connect;
WSocketsend.SendStr(StrMsg);
WSocketsend.Close;
end;
procedure TServiceForm.QueryState;
var
i: Integer;
begin
for i := 0 to Memo.Lines.Count - 1 do
SocketSend(Memo.Lines);
//查询状态
if ADOServer.Connected then
SocketSend('数据库连接：正在连接...')
else
SocketSend('数据库连接：正在等待...');
SocketSend('自动收取邮件间隔：' + IntToStr(UpDown_Timer.Position) + ' 分钟');
if TimerReceive.Enabled then
SocketSend('自动收取邮件计时器：正在计时...')
else
SocketSend('自动收取邮件计时器：正在等待...');
end;
end.
