邮件库（下）
procedure TMailStorage.PrepareSQLAndMaps;
const
cSelectMailSQL = 'select * from TMAILSYSTEM where (%s) and FCLIENTACCOUNT = ''%s''';
cDeleteMailWhereSQL = 'where FGUID not in (select DISTINCT FGUID from TMAILREFERENCE)';
cDeleteMailSQL = 'delete from TMAILSYSTEM ' + cDeleteMailWhereSQL;
cDeleteMailStreamSQL = 'delete from TMAILCONTENT ' + cDeleteMailWhereSQL;
cSelectStreamSQL = 'select * from TMAILCONTENT where (%s) and FCLIENTACCOUNT = ''%s'' ORDER BY FGUID, FINDEX, FSPLITNO';
cDeleteStreamSQL = 'delete from TMAILCONTENT where (%s) and FCLIENTACCOUNT = ''%s''';
cSelectNULLStreamSQL = 'select * from TMAILCONTENT where 1 <> 1';
//如果是Load状态，需要同时加载MailInfo的内容
cSelectMailRefSQL = 'select * from TMAILREFERENCE where (%s) and FCLIENTACCOUNT = ''%s''';
cSelectAllMailRefSQL = 'select a.*, b.* from TMAILREFERENCE a, TMAILSYSTEM b ' +
'where a.FGUID = b.FGUID and (%s) and b.FCLIENTACCOUNT = ''%s''';//a.FGUID in (select FGUID from TMAILREFERENCE where %s)';
cDeleteMailRefSQL = 'delete from TMAILREFERENCE where (%s) and FCLIENTACCOUNT = ''%s''';
cMoveMailRefSQL = 'update TMAILREFERENCE set FPATHGUID = ''%s'' where (%s) and FCLIENTACCOUNT = ''%s''';
cSelectPathSQL = 'select * from TMAILPATH where (%s) and FCLIENTACCOUNT = ''%s''';
cSelectSelfAndAllSubPathWhereSQL = 'select b.FGUID from TMAILPATH a, TMAILPATH b where ' +
'a.FGUID in (select FGUID from TMAILPATH where %s) and b.FPATH %s b.FGUID %s ''\'' like a.FPATH %s a.FGUID %s ''\%%'' and a.FCLIENTACCOUNT = ''%s''';
cDB2SelectSelfAndAllSubPathWhereSQL = 'select b.FGUID from TMAILPATH a, TMAILPATH b where ' +
'a.FGUID in (select FGUID from TMAILPATH where %s) and Upper(a.FPATH || a.FGUID) = Upper(SubStr((b.FPATH || b.FGUID), 1, Length(a.FPATH || a.FGUID))) and a.FCLIENTACCOUNT = ''%s''';
cDeletePathSQL = 'delete from TMAILPATH where FGUID in (%s) and FCLIENTACCOUNT = ''%s''';
cDeleteRefByPathSQL = 'delete from TMAILREFERENCE where FPATHGUID in (%s) and FCLIENTACCOUNT = ''%s''';
cMovePathSQL = 'update TMAILPATH set FPARENTGUID = ''%s'', FPATH = ''%s'' where( %s) and FCLIENTACCOUNT = ''%s''';
cUpdatePathANSISQL = 'update TMAILPATH set FPATH = ''%s'' || SUBSTRING(FPATH from %d for 255) where FPATH like ''%s'' and FCLIENTACCOUNT = ''%s''';
cUpdatePathMSSQLSQL = 'update TMAILPATH set FPATH = ''%s'' + SUBSTRING(FPATH, %d, 255) where FPATH like ''%s'' and FCLIENTACCOUNT = ''%s''';
cUpdatePathOracleSQL = 'update TMAILPATH set FPATH = ''%s'' || SUBSTR(FPATH, %d, 255) where FPATH like ''%s'' and FCLIENTACCOUNT = ''%s''';
cUpdatePathDB2SQL = 'update TMAILPATH set FPATH = ''%s'' || SUBSTR(FPATH, %d, Length(FPATH)) where FPATH like ''%s'' and FCLIENTACCOUNT = ''%s''';
cSelectAccountSQL = 'select * from TMAILACCOUNTS where (%s) and FCLIENTACCOUNT = ''%s''';
cDeleteAccountSQL = 'delete from TMAILACCOUNTS where (%s) and FCLIENTACCOUNT = ''%s''';
var
lSymbol: string;
lOldPath, lNewPath: string;
lMailInfoSQL, lMailStreamSQL, lMailReferenceSQL, lMailPathSQL, lMailAccountSQL: string;
lMISelectSQL, lMIDeleteSQL, lMISDeleteSQL: string;
lMSSelectSQL, lMSDeleteSQL: string;
lMRSelectSQL, lMRDeleteSQL, lMRMoveSQL: string;
lMPSelectSQL, lMPDeleteSQL, lMPRDeleteSQL, lMPMoveSQL, lMPMoveSQLEx, lDeleteStr: string;
lMASelectSQL, lMADeleteSQL: string;
lFieldPrefix: string;
lCommand: TMailMovePathStorageCommand;
begin
if FCommands.Count = 0 then Exit;
lMISelectSQL := '';
lMIDeleteSQL := '';
lMISDeleteSQL := '';
lMSSelectSQL := '';
lMSDeleteSQL := '';
lMRSelectSQL := '';
lMRDeleteSQL := '';
lMRMoveSQL := '';
lMPSelectSQL := '';
lMPDeleteSQL := '';
lMPMoveSQL := '';
lMPMoveSQLEx := '';
lMASelectSQL := '';
lMADeleteSQL := '';
lMailInfoSQL := GetSQLFromCommandList(FCommands, TMailDataKind.mskInfo, '');
lMailStreamSQL := GetSQLFromCommandList(FCommands, TMailDataKind.mskStream, '');
if Action = TMailStorageAction.msaLoad then
lFieldPrefix := 'a.'
else
lFieldPrefix := '';
lMailReferenceSQL := GetSQLFromCommandList(FCommands,
TMailDataKind.mskReference, lFieldPrefix);
lMailPathSQL := GetSQLFromCommandList(FCommands, TMailDataKind.mskPath, '');
lMailAccountSQL := GetSQLFromCommandList(FCommands, TMailDataKind.mskAccount, '');
if lMailInfoSQL <> '' then
begin
if Action in [TMailStorageAction.msaDelete, TMailStorageAction.msaMove] then
Assert(False, '不能够移动或直接删除邮件实体')
else
lMISelectSQL := Format(cSelectMailSQL, [lMailInfoSQL, BizSys.BizSystem.ClientAccount]);
end;
if lMailStreamSQL <> '' then
begin
case Action of
TMailStorageAction.msaLoad:
lMSSelectSQL := Format(cSelectStreamSQL, [lMailStreamSQL, BizSys.BizSystem.ClientAccount]);
TMailStorageAction.msaSave:
begin
lMSDeleteSQL := Format(cDeleteStreamSQL, [lMailStreamSQL, BizSys.BizSystem.ClientAccount]);
lMSSelectSQL := cSelectNULLStreamSQL;
end;
TMailStorageAction.msaDelete:
lMSDeleteSQL := Format(cDeleteStreamSQL, [lMailStreamSQL, BizSys.BizSystem.ClientAccount]);
else
Assert(False, '不能够移动邮件内容或者附件')
end;
end;
if lMailReferenceSQL <> '' then
begin
case Action of
TMailStorageAction.msaLoad:
lMRSelectSQL := Format(cSelectAllMailRefSQL, [lMailReferenceSQL, BizSys.BizSystem.ClientAccount]);
TMailStorageAction.msaSave:
lMRSelectSQL := Format(cSelectMailRefSQL, [lMailReferenceSQL, BizSys.BizSystem.ClientAccount]);
TMailStorageAction.msaDelete:
begin
lMRDeleteSQL := Format(cDeleteMailRefSQL, [lMailReferenceSQL, BizSys.BizSystem.ClientAccount]);
//删除没有引用的邮件实体
lMISDeleteSQL := cDeleteMailStreamSQL;
lMIDeleteSQL := cDeleteMailSQL;
end;
TMailStorageAction.msaMove:
lMRMoveSQL := Format(cMoveMailRefSQL,
[TMailMoveRefStorageCommand(FCommands.Items[0]).FNewPath, lMailReferenceSQL, BizSys.BizSystem.ClientAccount]);
end;
end;
//Path
if lMailPathSQL <> '' then
begin
lCommand := TMailMovePathStorageCommand(FCommands.Items[0]);
case Action of
TMailStorageAction.msaLoad, TMailStorageAction.msaSave:
lMPSelectSQL := Format(cSelectPathSQL, [lMailPathSQL, BizSys.BizSystem.ClientAccount]);
TMailStorageAction.msaDelete:
begin
if SameText(Connection.Meta.DataProvider, cDriver_MSSQL) or
SameText(Connection.Meta.DataProvider, cDriver_SYBASE) then
lSymbol := '+'
else
lSymbol := '||';
if SameText(Connection.Meta.DataProvider, cDriver_DB2) then
lDeleteStr := Format(cDB2SelectSelfAndAllSubPathWhereSQL, [lMailPathSQL, BizSys.BizSystem.ClientAccount])
else
lDeleteStr := Format(cSelectSelfAndAllSubPathWhereSQL, [lMailPathSQL, lSymbol, lSymbol, lSymbol, lSymbol, BizSys.BizSystem.ClientAccount]);
//要先删除下面的引用
lMPRDeleteSQL := Format(cDeleteRefByPathSQL, [lDeleteStr, BizSys.BizSystem.ClientAccount]);
//删除Path
lMPDeleteSQL := Format(cDeletePathSQL, [lDeleteStr, BizSys.BizSystem.ClientAccount]);
//删除没有引用的邮件实体
lMISDeleteSQL := cDeleteMailStreamSQL;
lMIDeleteSQL := cDeleteMailSQL;
end;
TMailStorageAction.msaMove:
begin
lMPMoveSQL := Format(cMovePathSQL, [lCommand.FNewParent, lCommand.FNewPath, lMailPathSQL, BizSys.BizSystem.ClientAccount]);
if SameText(Connection.Meta.DataProvider, cDriver_ORACLE) then
lMPMoveSQLEx := cUpdatePathOracleSQL
else if SameText(Connection.Meta.DataProvider, cDriver_DB2) then
lMPMoveSQLEx := cUpdatePathDB2SQL
else if SameText(Connection.Meta.DataProvider, cDriver_MSSQL) then
lMPMoveSQLEx := cUpdatePathMSSQLSQL
else if SameText(Connection.Meta.DataProvider, cDriver_SQLITE) then
lMPMoveSQLEx := cUpdatePathOracleSQL
else if SameText(Connection.Meta.DataProvider, cDriver_Sybase) then
lMPMoveSQLEx := cUpdatePathMSSQLSQL
else
lMPMoveSQLEx := cUpdatePathANSISQL;
lNewPath := lCommand.FNewPath + lCommand.Key.Scope + '\';
lOldPath := lCommand.FOldPath + lCommand.Key.Scope + '\%';
lMPMoveSQLEx := Format(lMPMoveSQLEx, [lNewPath, Length(lOldPath), lOldPath, BizSys.BizSystem.ClientAccount]);
end;
end;
end;
//Account
if lMailAccountSQL <> '' then
begin
case Action of
TMailStorageAction.msaLoad, TMailStorageAction.msaSave:
lMASelectSQL := Format(cSelectAccountSQL, [lMailAccountSQL, BizSys.BizSystem.ClientAccount]);
TMailStorageAction.msaDelete:
lMADeleteSQL := Format(cDeleteAccountSQL, [lMailAccountSQL, BizSys.BizSystem.ClientAccount]);
else
Assert(False, '不能够移动邮件帐号')
end;
end;
//删除时的顺序：Stream, Refrence, Path, Info, Account
AddSQLAndMap(lMSDeleteSQL, [], lMSDeleteSQL <> '');
AddSQLAndMap(lMRDeleteSQL, [], lMRDeleteSQL <> '');
AddSQLAndMap(lMPRDeleteSQL, [], lMPRDeleteSQL <> '');
AddSQLAndMap(lMPDeleteSQL, [], lMPDeleteSQL <> '');
AddSQLAndMap(lMISDeleteSQL, [], lMISDeleteSQL <> '');
AddSQLAndMap(lMIDeleteSQL, [], lMIDeleteSQL <> '');
AddSQLAndMap(lMADeleteSQL, [], lMADeleteSQL <> '');
//创建和修改时先操作Info
AddSQLAndMap(lMISelectSQL, [], False);
AddSQLAndMap(lMSSelectSQL, [], False);
AddSQLAndMap(lMPSelectSQL, [], False);
AddSQLAndMap(lMRSelectSQL, [], False);
AddSQLAndMap(lMASelectSQL, [], False);
//移动的SQL
AddSQLAndMap(lMRMoveSQL, [], lMRMoveSQL <> '');
AddSQLAndMap(lMPMoveSQL, [], lMPMoveSQL <> '');
AddSQLAndMap(lMPMoveSQLEx, [], lMPMoveSQLEx <> '');
end;
function TMailStorage.GetDateSQL(const ADateTime: TDateTime;
const AFieldName, ASymbol: string): string;
begin
Result := Format('%s %s ''%s''', [AFieldName, ASymbol, FormatDateTime('yyyy-mm-dd 00:00:00', ADateTime)]);
end;
{ TMailStorageCommand }
procedure TMailStorageCommand.DoLoad(AStorage: TMailStorage);
begin
{ nothing to do }
end;
procedure TMailStorageCommand.DoSave(AStorage: TMailStorage);
begin
{ nothing to do }
end;
procedure TMailStorageCommand.DoStorage(AStorage: TMailStorage);
begin
with AStorage do
if Assigned(DataSets[GetDataSetIndex]) then
begin
case Action of
{ 从DataSet中取数据 }
TMailStorageAction.msaLoad: DoLoad(AStorage);
{ 设置数据到DataSet中 }
TMailStorageAction.msaSave: DoSave(AStorage);
end;
end;
end;
procedure SetMailInfoByDataSet(AMailInfo: TMailInfo; ADataSet: TDataSet);
begin
AMailInfo.MailGUID := ADataSet.FieldByName('FGUID').AsString;
AMailInfo.UIDL := ADataSet.FieldByName('FUIDL').AsString;
AMailInfo.Size := ADataSet.FieldByName('FSIZE').AsInteger;
AMailInfo.HasAttach := Boolean(ADataSet.FieldByName('FHASATTACH').AsInteger);
AMailInfo.Tos := ADataSet.FieldByName('FTOS').AsString;
AMailInfo.From := ADataSet.FieldByName('FFROM').AsString;
AMailInfo.Cc := ADataSet.FieldByName('FCC').AsString;
AMailInfo.Bcc := ADataSet.FieldByName('FBCC').AsString;
AMailInfo.ReplyTo := ADataSet.FieldByName('FREPLYTO').AsString;
AMailInfo.Subject := ADataSet.FieldByName('FSUBJECT').AsString;
AMailInfo.Priority := ADataSet.FieldByName('FPRIORITY').AsInteger;
AMailInfo.Date := ADataSet.FieldByName('FDATE').AsDateTime;
AMailInfo.HeaderText := ADataSet.FieldByName('FHEADER').AsString;
AMailInfo.AttachmentInfos.Text := ADataSet.FieldByName('FATTACHMENTINFOS').AsString;
end;
{ TMailInfoStorageCommand }
constructor TMailInfoStorageCommand.Create(AMailInfo: TMailInfo);
begin
inherited Create;
FMailInfo := AMailInfo;
end;
procedure TMailInfoStorageCommand.DoLoad(AStorage: TMailStorage);
var
lDataSet: TDataSet;
begin
if Key.ScopeKind = TMailScopeKind.skGUID then
begin
lDataSet := AStorage.DataSets[GetDataSetIndex];
if lDataSet.Locate('FGUID', Key.Scope, []) then
SetMailInfoByDataSet(FMailInfo, lDataSet);
end
else
Assert(False, '没有支持的方法');
end;
procedure TMailInfoStorageCommand.DoSave(AStorage: TMailStorage);
var
lDataSet: TDataSet;
begin
if Key.ScopeKind = TMailScopeKind.skGUID then
begin
lDataSet := AStorage.DataSets[GetDataSetIndex];
if lDataSet.Locate('FGUID', Key.Scope, []) then
lDataSet.Edit
else
begin
lDataSet.Append;
lDataSet.FieldByName('FCLIENTACCOUNT').AsString := BizSys.BizSystem.ClientAccount;
end;
lDataSet.FieldByName('FGUID').AsString := FMailInfo.MailGUID;
lDataSet.FieldByName('FUIDL').AsString := FMailInfo.UIDL;
lDataSet.FieldByName('FSIZE').AsInteger := FMailInfo.Size;
lDataSet.FieldByName('FHASATTACH').AsInteger := Ord(FMailInfo.HasAttach);
lDataSet.FieldByName('FTOS').AsString := FMailInfo.Tos;
lDataSet.FieldByName('FFROM').AsString := FMailInfo.From;
lDataSet.FieldByName('FCC').AsString := FMailInfo.Cc;
lDataSet.FieldByName('FBCC').AsString := FMailInfo.Bcc;
lDataSet.FieldByName('FREPLYTO').AsString := FMailInfo.ReplyTo;
lDataSet.FieldByName('FSUBJECT').AsString := FMailInfo.Subject;
lDataSet.FieldByName('FPRIORITY').AsInteger := FMailInfo.Priority;
if FMailInfo.Date = 0 then
lDataSet.FieldByName('FDATE').AsDateTime := SysUtils.Now
else
lDataSet.FieldByName('FDATE').AsDateTime := FMailInfo.Date;
lDataSet.FieldByName('FHEADER').AsString := FMailInfo.HeaderText;
lDataSet.FieldByName('FATTACHMENTINFOS').AsString := FMailInfo.AttachmentInfos.Text;
lDataSet.Post;
end
else
Assert(False, '没有支持的方法');
end;
function TMailInfoStorageCommand.GetDataSetIndex: Integer;
begin
Result := MIS;
end;
{ TMailStreamStorageCommand }
constructor TMailStreamStorageCommand.Create(AMailAttachment: TMailAttachment);
begin
inherited Create;
FMailAttachment := AMailAttachment;
end;
procedure TMailStreamStorageCommand.DoLoad(AStorage: TMailStorage);
begin
SetStream(AStorage.DataSets[GetDataSetIndex], FMailAttachment.Index,
FMailAttachment.Content);
end;
procedure TMailStreamStorageCommand.DoSave(AStorage: TMailStorage);
begin
SetDataSet(AStorage.DataSets[GetDataSetIndex], FMailAttachment.Index,
FMailAttachment.Content);
end;
procedure TMailStreamStorageCommand.SetStream(ADataSet: TDataSet;
const AIndex: Integer; AStream: TStream);
var
lArrObject: array of Object;
lObject: Object;
begin
SetLength(lArrObject, 2);
lArrObject[0] := Key.Scope;
lArrObject[1] := AIndex;
ReadSplitFieldCntFromDataSet(ADataSet, 'FGUID;FINDEX', 'FSPLITNO', 'FCONTENT',
'', lArrObject, lObject, AStream, True);
end;
procedure TMailStreamStorageCommand.SetDataSet(ADataSet: TDataSet;
const AIndex: Integer; AStream: TStream);
var
lObject: Object;
lArrObject: array of Object;
begin
if AStream.Size > 0 then
begin
SetLength(lArrObject, 2);
lArrObject[0] := Key.Scope;
lArrObject[1] := AIndex;
lObject := MakeHashValue(AStream);
WriteSplitFieldCntToDataSet(ADataSet, 'FGUID;FINDEX', 'FSPLITNO',
'FCONTENT', 'FHASHVALUE', lArrObject, lObject, AStream, True, True);
end;
end;
function TMailStreamStorageCommand.GetDataSetIndex: Integer;
begin
Result := MSS;
end;
{ TMailMultiStreamStorageCommand }
constructor TMailMultiStreamStorageCommand.Create(AStreamList: TList;
const AStartIndex: Integer);
begin
inherited Create;
FStreamList := AStreamList;
FStartIndex := AStartIndex;
end;
procedure TMailMultiStreamStorageCommand.DoLoad(AStorage: TMailStorage);
begin
Assert(False, '邮件附件不能够成批读取');
end;
procedure TMailMultiStreamStorageCommand.DoSave(AStorage: TMailStorage);
var
I: Integer;
lDataSet: TDataSet;
begin
lDataSet := AStorage.DataSets[GetDataSetIndex];
for I := 0 to FStreamList.Count - 1 do
SetDataSet(lDataSet, FStartIndex + I, TStream(FStreamList[I]));
end;
{ TMailRefStorageCommand }
constructor TMailRefStorageCommand.Create(AMailRef: TMailReference);
begin
inherited Create;
FMailRef := AMailRef;
end;
procedure TMailRefStorageCommand.SetMailRef(ADataSet: TDataSet; AMailRef: TMailReference);
begin
AMailRef.MailGUID := ADataSet.FieldByName('FGUID').AsString;
AMailRef.OwnerGUID := ADataSet.FieldByName('FOWNERGUID').AsString;
AMailRef.AccountGUID := ADataSet.FieldByName('FACCOUNTGUID').AsString;
AMailRef.PathGUID := ADataSet.FieldByName('FPATHGUID').AsString;
AMailRef.Time := ADataSet.FieldByName('FTIME').AsDateTime;
AMailRef.Size := ADataSet.FieldByName('FSIZE').AsInteger;
AMailRef.State := ADataSet.FieldByName('FSTATE').AsInteger;
SetMailInfoByDataSet(AMailRef.MailInfo, ADataSet);
end;
procedure TMailRefStorageCommand.DoLoad(AStorage: TMailStorage);
var
lArrObject: array of Object;
lDataSet: TDataSet;
begin
if Key.ScopeKind = TMailScopeKind.skGUID then
begin
lDataSet := AStorage.DataSets[GetDataSetIndex];
SetLength(lArrObject, 2);
lArrObject[0] := Key.Scope;
lArrObject[1] := Key.OwnerGUID;
if lDataSet.Locate('FGUID;FOWNERGUID', lArrObject, [TLocateOption.loCaseInsensitive]) then
SetMailRef(lDataSet, FMailRef);
end
else
Assert(False, '没有支持的方法');
end;
procedure TMailRefStorageCommand.DoSave(AStorage: TMailStorage);
var
lDataSet: TDataSet;
lArrObject: array of Object;
begin
if Key.ScopeKind = TMailScopeKind.skGUID then
begin
lDataSet := AStorage.DataSets[GetDataSetIndex];
SetLength(lArrObject, 3);
lArrObject[0] := Key.Scope;
lArrObject[1] := Key.OwnerGUID;
lArrObject[2] := Key.PathGUID;
//SMP ADD 原来的写法突然出错异常信息，记录已经被修改了，像下面这样写就OK了 20060928
lDataSet.UpdateOptions.UpdateMode := TUpdateMode.upWhereKeyOnly;
lDataSet.UpdateOptions.Fields.Clear;
with lDataSet.UpdateOptions.Fields.Add do
begin
Name := 'FGUID';
ProviderFlags := [TProviderFlag.pfInKey];
end;
with lDataSet.UpdateOptions.Fields.Add do
begin
Name := 'FOWNERGUID';
ProviderFlags := [TProviderFlag.pfInKey];
end;
with lDataSet.UpdateOptions.Fields.Add do
begin
Name := 'FPATHGUID';
ProviderFlags := [TProviderFlag.pfInKey];
end;
with lDataSet.UpdateOptions.Fields.Add do
begin
Name := 'FCLIENTACCOUNT';
ProviderFlags := [TProviderFlag.pfInKey];
end;
//END
if lDataSet.Locate('FGUID;FOWNERGUID;FPATHGUID', lArrObject, [TLocateOption.loCaseInsensitive]) then
lDataSet.Edit
else
begin
lDataSet.Append;
lDataSet.FieldByName('FCLIENTACCOUNT').AsString := BizSys.BizSystem.ClientAccount;
end;
lDataSet.FieldByName('FGUID').AsString := FMailRef.MailGUID;
lDataSet.FieldByName('FOWNERGUID').AsString := FMailRef.OwnerGUID;
lDataSet.FieldByName('FACCOUNTGUID').AsString := FMailRef.AccountGUID;
lDataSet.FieldByName('FPATHGUID').AsString := FMailRef.PathGUID;
lDataSet.FieldByName('FTIME').AsDateTime := FMailRef.Time;
lDataSet.FieldByName('FSIZE').AsInteger := FMailRef.Size;
lDataSet.FieldByName('FSTATE').AsInteger := FMailRef.State;
lDataSet.Post;
end
else
Assert(False, '没有支持的方法');
end;
function TMailRefStorageCommand.GetDataSetIndex: Integer;
begin
Result := MRS;
end;
{ TMailMulitRefStorageCommand }
constructor TMailMulitRefStorageCommand.Create(
ASearchMailParam: TSearchMailParam; AMailRefList: TStrings);
begin
inherited Create;
FSearchMailParam := ASearchMailParam;
FMailRefList := AMailRefList;
end;
procedure TMailMulitRefStorageCommand.DoLoad(AStorage: TMailStorage);
var
lDataSet: TDataSet;
lMailRef: TMailReference;
begin
lDataSet := AStorage.DataSets[GetDataSetIndex];
lDataSet.First;
while not lDataSet.Eof do
begin
lMailRef := TMailReference.Create;
try
SetMailRef(lDataSet, lMailRef);
FMailRefList.AddObject(lMailRef.MailGUID, lMailRef);
lDataSet.Next;
except
lMailRef.Free;
raise;
end;
end;
end;
procedure TMailMulitRefStorageCommand.DoSave(AStorage: TMailStorage);
begin
Assert(False, '不支持的动作');
end;
{ TMailPathStorageCommand }
constructor TMailPathStorageCommand.Create(AMailPath: TMailPath);
begin
inherited Create;
FMailPath := AMailPath;
end;
procedure TMailPathStorageCommand.SetPath(ADataSet: TDataSet; AMailPath: TMailPath);
begin
AMailPath.PathGUID := ADataSet.FieldByName('FGUID').AsString;
AMailPath.ParentGUID := ADataSet.FieldByName('FPARENTGUID').AsString;
AMailPath.OwnerGUID := ADataSet.FieldByName('FOWNERGUID').AsString;
AMailPath.DisplayName := ADataSet.FieldByName('FDISPLAYNAME').AsString;
AMailPath.ParentPath := ADataSet.FieldByName('FPATH').AsString;
end;
procedure TMailPathStorageCommand.DoLoad(AStorage: TMailStorage);
var
lDataSet: TDataSet;
begin
if Key.ScopeKind = TMailScopeKind.skGUID then
begin
lDataSet := AStorage.DataSets[GetDataSetIndex];
if lDataSet.Locate('FGUID', Key.Scope, []) then
SetPath(lDataSet, FMailPath);
end
else
Assert(False, '没有支持的方法');
end;
procedure TMailPathStorageCommand.DoSave(AStorage: TMailStorage);
var
lDataSet: TDataSet;
begin
if Key.ScopeKind = TMailScopeKind.skGUID then
begin
lDataSet := AStorage.DataSets[GetDataSetIndex];
if lDataSet.Locate('FGUID', Key.Scope, []) then
lDataSet.Edit
else
begin
lDataSet.Append;
lDataSet.FieldByName('FCLIENTACCOUNT').AsString := BizSys.BizSystem.ClientAccount;
end;
lDataSet.FieldByName('FGUID').AsString := FMailPath.PathGUID;
lDataSet.FieldByName('FPARENTGUID').AsString := FMailPath.ParentGUID;
lDataSet.FieldByName('FOWNERGUID').AsString := FMailPath.OwnerGUID;
lDataSet.FieldByName('FDISPLAYNAME').AsString := FMailPath.DisplayName;
lDataSet.FieldByName('FPATH').AsString := FMailPath.ParentPath;
lDataSet.Post;
end
else
Assert(False, '没有支持的方法');
end;
function TMailPathStorageCommand.GetDataSetIndex: Integer;
begin
Result := MPS;
end;
{ TMailMulitPathStorageCommand }
constructor TMailMulitPathStorageCommand.Create(AMailPathList: TStrings);
begin
inherited Create;
FMailPathList := AMailPathList;
end;
procedure TMailMulitPathStorageCommand.DoLoad(AStorage: TMailStorage);
var
lDataSet: TDataSet;
lMailPath: TMailPath;
begin
lDataSet := AStorage.DataSets[GetDataSetIndex];
lDataSet.First;
while not lDataSet.Eof do
begin
lMailPath := TMailPath.Create;
try
SetPath(lDataSet, lMailPath);
FMailPathList.AddObject(lMailPath.FullPath, lMailPath);
lDataSet.Next;
except
lMailPath.Free;
raise;
end;
end;
end;
procedure TMailMulitPathStorageCommand.DoSave(AStorage: TMailStorage);
begin
Assert(False, '不支持的动作');
end;
{ TMailInfo }
constructor TMailInfo.Create;
begin
inherited;
MailGUID := '';
UIDL := '';
HasAttach := False;
Tos := '';
From := '';
Cc := '';
Bcc := '';
ReplyTo := '';
Subject := '';
HeaderText := '';
FAttachmentInfos := TStringList.Create;
end;
destructor TMailInfo.Destroy;
begin
FAttachmentInfos.Free;
inherited;
end;
procedure TMailInfo.Assign(Source: TPersistent);
var
lSourceMailInfo: TMailInfo;
begin
lSourceMailInfo := TMailInfo(Source);
MailGUID := lSourceMailInfo.MailGUID;
UIDL := lSourceMailInfo.UIDL;
Size := lSourceMailInfo.Size;
HasAttach := lSourceMailInfo.HasAttach;
Tos := lSourceMailInfo.Tos;
From := lSourceMailInfo.From;
Cc := lSourceMailInfo.Cc;
Bcc := lSourceMailInfo.Bcc;
ReplyTo := lSourceMailInfo.ReplyTo;
Subject := lSourceMailInfo.Subject;
Priority := lSourceMailInfo.Priority;
Date := lSourceMailInfo.Date;
HeaderText := lSourceMailInfo.HeaderText;
AttachmentInfos.Text := lSourceMailInfo.AttachmentInfos.Text;
end;
function TMailInfo.GetHeaderText: string;
begin
Result := FHeaderText;
end;
procedure TMailInfo.SetHeaderText(const Value: string);
begin
FHeaderText := Value;
UpdateProperties;
end;
procedure TMailInfo.UpdateProperties;
begin
//TODO: 解析Header，生成属性
//是否在设置属性后还要修改HeaderText呢？
end;
{ TMailSystem }
constructor TMailSystem.Create;
begin
inherited;
FMailInfoList := TStringList.Create;
FMailInfoList.Sorted := True;
FMailInfoList.Duplicates := TDuplicates.dupError;
FMailRefList := TStringList.Create;
FMailRefList.Sorted := True;
FMailRefList.Duplicates := TDuplicates.dupError;
FReceiveMsgExchg := TMessageExchanger.Create(nil);
FReceiveMsgExchg.MessageKind := TMessageKind.mkReceive;
FSendMsgExchg := TMessageExchanger.Create(nil);
FSendMsgExchg.MessageKind := TMessageKind.mkSend;
FOutMails := TStringList.Create;
FMailSending := TStringList.Create;
end;
destructor TMailSystem.Destroy;
var
I: Integer;
lObject: TObject;
begin
for I := 0 to FMailInfoList.Count - 1 do
begin
lObject := FMailInfoList.Objects[I];
FreeAndNil(lObject);
end;
FMailInfoList.Free;
for I := 0 to FMailRefList.Count - 1 do
begin
lObject := FMailRefList.Objects[I];
FreeAndNil(lObject);
end;
FMailRefList.Free;
FReceiveMsgExchg.Free;
FSendMsgExchg.Free;
FOutMails.Free;
FMailSending.Free;
inherited;
end;
static function TMailSystem.CreateMailSystem: TMailSystem;
begin
if MailSystem = nil then
MailSystem := TMailSystem.Create;
Result := MailSystem;
end;
static procedure TMailSystem.DestroyMailSystem;
begin
if MailSystem <> nil then
begin
MailSystem.Free;
MailSystem := nil;
end;
end;
function TMailSystem.FindMailInfo(const AMailGUID: string): TMailInfo;
var
I: Integer;
lMailStorage: TMailStorage;
lMailInfo: TMailInfo;
begin
Result := DoFindMailInfo(AMailGUID);
if Result = nil then
begin
lMailInfo := TMailInfo.Create;
try
lMailStorage := TMailStorage.Create(TMailStorageAction.msaLoad);
try
lMailStorage.AddMailInfoCommand(MakeKey(AMailGUID, TMailScopeKind.skGUID, '', ''), lMailInfo);
lMailStorage.Execute;
if lMailInfo.MailGUID <> '' then
begin
AddMailInfo(lMailInfo);
Result := lMailInfo;
end;
finally
lMailStorage.Free;
end;
except
lMailInfo.Free;
raise;
end;
end;
end;
function TMailSystem.FindMailRef(const AMailGUID, APath: string): TMailReference;
var
lMailStorage: TMailStorage;
lMailRef: TMailReference;
begin
Result := DoFindMailRef(AMailGUID, APath);
if Result = nil then
begin
lMailRef := TMailReference.Create;
try
lMailStorage := TMailStorage.Create(TMailStorageAction.msaLoad);
try
lMailStorage.AddMailRefCommand(MakeKey(AMailGUID, TMailScopeKind.skGUID, OperateUser, APath), lMailRef);
lMailStorage.Execute;
if lMailRef.MailGUID <> '' then
begin
Assert(SameText(lMailRef.OwnerGUID, OperateUser), '');
AddMailRef(lMailRef);
Result := lMailRef;
end;
finally
lMailStorage.Free;
end;
except
lMailRef.Free;
raise;
end;
end;
end;
function TMailSystem.GetMailInfo(const AMailGUID: string): TMailInfo;//包含附件列表
begin
Result := FindMailInfo(AMailGUID);
if Result = nil then
raise Exception.CreateFmt('没有找到 GUID = "%s" 的邮件', [AMailGUID]);
end;
function TMailSystem.GetMailRef(const AMailGUID, APath: string): TMailReference;
begin
Result := FindMailRef(AMailGUID, APath);
if Result = nil then
raise Exception.CreateFmt('没有在目录 "%s" 下面找到 GUID = "%s" 的邮件', [APath, AMailGUID]);
end;
function TMailSystem.SaveMail(const AMailGUID, APath: string;
AMailStream: TStream): TMailReference;
var
lMailRef: TMailReference;
lMailContent: TStream;
lMailAttachments: TList;
begin
//TODO: 分解MailStream，然后创建邮件
SaveMail(lMailRef, lMailContent, lMailAttachments);
end;
procedure TMailSystem.SaveMail(AMailRef: TMailReference; AMailContent: TStream;
AMailAttachments: TList);
var
lMailStorage: TMailStorage;
lMailAttachment: TMailAttachment;
begin
lMailStorage := TMailStorage.Create(TMailStorageAction.msaSave);
lMailAttachment := TMailAttachment.Create;
try
lMailStorage.AddMailInfoCommand(MakeKey(AMailRef.MailGUID,
TMailScopeKind.skGUID, '', ''), AMailRef.MailInfo);
lMailStorage.AddMailRefCommand(MakeKey(AMailRef.MailGUID,
TMailScopeKind.skGUID, OperateUser, AMailRef.PathGUID), AMailRef);
if AMailContent <> nil then
begin
if AMailContent.Size > 0 then
lMailAttachment.Content.CopyFrom(AMailContent, 0);
lMailAttachment.Index := 0;
lMailStorage.AddStreamCommand(MakeKey(AMailRef.MailGUID,
TMailScopeKind.skGUID, '', ''), lMailAttachment);
end;
if AMailAttachments <> nil then
lMailStorage.AddMultiAttachmentCommand(MakeKey(AMailRef.MailGUID,
TMailScopeKind.skGUID, '', ''), AMailAttachments, 1);
lMailStorage.Execute;
AddMailRef(AMailRef);
finally
lMailAttachment.Free;
lMailStorage.Free;
end;
end;
procedure TMailSystem.DeleteMail(const AMailGUID, APath: string);
var
lMailStorage: TMailStorage;
lMailRef: TMailReference;
begin
lMailStorage := TMailStorage.Create(TMailStorageAction.msaDelete);
lMailRef := TMailReference.Create;
try
lMailRef.MailGUID := AMailGUID;
lMailRef.PathGUID := APath;
lMailStorage.AddMailRefCommand(MakeKey(AMailGUID, TMailScopeKind.skGUID,
OperateUser, APath), lMailRef);
lMailStorage.Execute;
DeleteMailInfo(AMailGUID);
DeleteMailRef(AMailGUID, APath);
finally
lMailRef.Free;
lMailStorage.Free;
end;
end;
procedure TMailSystem.MoveMail(const AMailGUID, AOldPath,
ANewPath: string);
var
lMailStorage: TMailStorage;
lMailRef: TMailReference;
begin
lMailStorage := TMailStorage.Create(TMailStorageAction.msaMove);
try
lMailStorage.AddMoveRefCommand(MakeKey(AMailGUID, TMailScopeKind.skGUID,
OperateUser, AOldPath), ANewPath);
lMailStorage.Execute;
DeleteMailRef(AMailGUID, AOldPath);
{lMailRef := DoFindMailRef(AMailGUID, ANewPath);
if lMailRef <> nil then
lMailRef.PathGUID := ANewPath;
//raise Exception.Create('移动邮件出错');}
finally
lMailStorage.Free;
end;
end;
procedure TMailSystem.SaveMailRef(AMailRef: TMailReference);
var
lMailStorage: TMailStorage;
begin
lMailStorage := TMailStorage.Create(TMailStorageAction.msaSave);
try
lMailStorage.AddMailRefCommand(MakeKey(AMailRef.MailGUID,
TMailScopeKind.skGUID, AMailRef.OwnerGUID, AMailRef.PathGUID), AMailRef);
lMailStorage.Execute;
AddMailRef(AMailRef);
finally
lMailStorage.Free;
end;
end;
procedure TMailSystem.SaveMailRefList(AMailRefList: TObjectList);
var
lMailStorage: TMailStorage;
I: Integer;
lMailRef: TMailReference;
begin
lMailStorage := TMailStorage.Create(TMailStorageAction.msaSave);
try
for I := 0 to AMailRefList.Count - 1 do
begin
lMailRef := TMailReference(AMailRefList.Items[I]);
lMailStorage.AddMailRefCommand(MakeKey(lMailRef.MailGUID,
TMailScopeKind.skGUID, lMailRef.OwnerGUID, lMailRef.PathGUID), lMailRef);
end;
lMailStorage.Execute;
finally
lMailStorage.Free;
end;
end;
procedure TMailSystem.LoadMailContent(const AMailGUID: string; AStream: TStream);
var
lMailAttachment: TMailAttachment;
begin
lMailAttachment := TMailAttachment.Create;
try
lMailAttachment.Index := 0;
LoadMailAttachment(AMailGUID, lMailAttachment);
AStream.CopyFrom(lMailAttachment.Content, 0);
finally
lMailAttachment.Free;
end;
end;
procedure TMailSystem.LoadMailAttachment(const AMailGUID: string;
AMailAttachment: TMailAttachment);
var
lMailStorage: TMailStorage;
begin
lMailStorage := TMailStorage.Create(TMailStorageAction.msaLoad);
try
lMailStorage.AddStreamCommand(MakeKey(AMailGUID, TMailScopeKind.skGUID, '', ''), AMailAttachment);
lMailStorage.Execute;
finally
lMailStorage.Free;
end;
end;
procedure TMailSystem.LoadMailAttachment(const AMailGUID: string; Index: Integer; AStream: TStream);
var
lMailAttachment: TMailAttachment;
begin
lMailAttachment := TMailAttachment.Create;
try
lMailAttachment.Index := Index;
LoadMailAttachment(AMailGUID, lMailAttachment);
AStream.Size := lMailAttachment.Content.Size;
AStream.CopyFrom(lMailAttachment.Content, 0);
finally
lMailAttachment.Free;
end;
end;
function TMailSystem.DoSearchMail(const AOperateUser, APath: string;
const ASearchMailParam: TSearchMailParam; AMailRefList: TStrings): Integer;
var
lMailStorage: TMailStorage;
lMailRefList: TStringList;
I: Integer;
lMailRef: TMailReference;
begin
lMailRefList := TStringList.Create;
try
lMailStorage := TMailStorage.Create(TMailStorageAction.msaLoad);
try
lMailStorage.AddMailMulitRefCommand(MakeKey(APath, TMailScopeKind.skPath, AOperateUser, ''),
ASearchMailParam, lMailRefList);
lMailStorage.Execute;
finally
lMailStorage.Free;
end;
Result := lMailRefList.Count;
//加入缓存
for I := 0 to lMailRefList.Count - 1 do
begin
lMailRef := TMailReference(lMailRefList.Objects[I]);
if SameText(lMailRef.OwnerGUID, OperateUser) then
begin
AddMailRef(lMailRef);
lMailRefList.Objects[I] := lMailRef;
end;
end;
if AMailRefList <> nil then
AMailRefList.AddStrings(lMailRefList);
finally
lMailRefList.Free;
end;
end;
function TMailSystem.SearchMail(const APath: string;
const ASearchMailParam: TSearchMailParam; AMailRefList: TStrings): Integer;
begin
Result := DoSearchMail(OperateUser, APath, ASearchMailParam, AMailRefList);
end;
function TMailSystem.SearcbMailUIDL(const AUIDL, AOperateUser: string;
AMailRefList: TStrings): Boolean;
begin
//把UIDL赋值给lSearchMailParam，并且从全局中查找
Result := DoSearchMail(AOperateUser, '\',
SearchMailParam('', '', '', '', AUIDL, 0, 0, -1, True), AMailRefList) > 0;
end;
function TMailSystem.SearchMailCount(const AMailGUID, AOperateUser: string): Integer;
begin
Result := DoSearchMail(AOperateUser, '\', SearchMailParam(AMailGUID, True), nil);
end;
procedure TMailSystem.GetMailPathList(APathList: TStrings);
var
lMailStorage: TMailStorage;
begin
lMailStorage := TMailStorage.Create(TMailStorageAction.msaLoad);
try
lMailStorage.AddMulitPathCommand(
MakeKey('', TMailScopeKind.skPath, OperateUser, ''), APathList);
lMailStorage.Execute;
finally
lMailStorage.Free;
end;
end;
procedure TMailSystem.GetMailPath(const APathGUID: string; AMailPath: TMailPath);
var
lMailStorage: TMailStorage;
begin
if GetDefaultMailPath(APathGUID, AMailPath) then
Exit;
lMailStorage := TMailStorage.Create(TMailStorageAction.msaLoad);
try
lMailStorage.AddPathCommand(MakeKey(APathGUID, TMailScopeKind.skGUID, OperateUser, ''), AMailPath);
lMailStorage.Execute;
if AMailPath.PathGUID = '' then
raise Exception.CreateFmt('GUID = "%s% 的目录不存在', [APathGUID]);
finally
lMailStorage.Free;
end;
end;
function TMailSystem.AddMailPath(const AGUID, AParentPathGUID,
APathDisplayname: string): TMailPath;
var
lMailStorage: TMailStorage;
lMailPath, lMailParentPath: TMailPath;
begin
lMailStorage := TMailStorage.Create(TMailStorageAction.msaSave);
try
lMailPath := TMailPath.Create;
try
//如果AGUID不为空，说明要修改这个目录的一些属性
if AGUID = '' then
lMailPath.PathGUID := CreateGUIDStr
else
lMailPath.PathGUID := AGUID;
lMailPath.ParentGUID := AParentPathGUID;
lMailPath.OwnerGUID := OperateUser;
lMailPath.DisplayName := APathDisplayName;
lMailParentPath := TMailPath.Create;
try
GetMailPath(AParentPathGUID, lMailParentPath);
lMailPath.ParentPath := lMailParentPath.FullPath;
finally
lMailParentPath.Free;
end;
lMailStorage.AddPathCommand(MakeKey(lMailPath.PathGUID,
TMailScopeKind.skGUID, OperateUser, ''), lMailPath);
lMailStorage.Execute;
Result := lMailPath;
except
lMailPath.Free;
raise;
end;
finally
lMailStorage.Free;
end;
end;
procedure TMailSystem.DeletePath(const APathGUID: string);
var
lMailStorage: TMailStorage;
begin
lMailStorage := TMailStorage.Create(TMailStorageAction.msaDelete);
try
lMailStorage.AddPathCommand(MakeKey(APathGUID, TMailScopeKind.skGUID,
OperateUser, ''), nil);
lMailStorage.Execute;
finally
lMailStorage.Free;
end;
end;
procedure TMailSystem.MovePath(const APathGUID, AOldParentPathGUID,
ANewParentPathGUID: string);
var
lMailStorage: TMailStorage;
lMailPath, lNewMailPath: TMailPath;
lNewPath: string;
begin
lMailStorage := TMailStorage.Create(TMailStorageAction.msaMove);
lMailPath := TMailPath.Create;
lNewMailPath := TMailPath.Create;
try
GetMailPath(APathGUID, lMailPath);
GetMailPath(ANewParentPathGUID, lNewMailPath);
lNewPath := lMailPath.ParentPath;
{if AOldParentPathGUID = cGUID_Root then
lNewPath := lNewPath + ANewParentPathGUID + '\'
else
lNewPath := Copy(lNewPath, 1, Length(lNewPath) - Length(lMailPath.ParentPath) - 1) +//AOldParentPathGUID
ANewParentPathGUID + '\';}
lNewPath := lNewMailPath.FullPath;
lMailStorage.AddMovePathCommand(MakeKey(APathGUID, TMailScopeKind.skGUID, OperateUser, ''),
AOldParentPathGUID, ANewParentPathGUID, lMailPath.ParentPath, lNewPath);
lMailStorage.Execute;
finally
lMailStorage.Free;
lMailPath.Free;
lNewMailPath.Free;
end;
end;
function TMailSystem.DoGetAccountList(const AOperateUser: string; AMailAccountList: TStrings): Integer;
var
lMailStorage: TMailStorage;
begin
lMailStorage := TMailStorage.Create(TMailStorageAction.msaLoad);
try
lMailStorage.AddMulitAccountCommand(
MakeKey('', TMailScopeKind.skPath, OperateUser, ''), AMailAccountList);
lMailStorage.Execute;
Result := AMailAccountList.Count;
finally
lMailStorage.Free;
end;
end;
procedure TMailSystem.CheckAccounts;
var
I: Integer;
lStrings: TStringList;
begin
if FAccounts = nil then
begin
lStrings := TStringList.Create;
try
lStrings.Sorted := True;
DoGetAccountList(OperateUser, lStrings);
FAccounts := TMailAccounts.Create(True);
for I := 0 to lStrings.Count - 1 do
FAccounts.Add(TMailAccount(lStrings.Objects[I]));
finally
lStrings.Free;
end;
end;
end;
function TMailSystem.GetDefaultMailPath(const APathGUID: string; AMailPath: TMailPath): Boolean;
var
lPathGUID: string;
lDisplayName: string;
begin
Result := True;
lPathGUID := UpperCase(APathGUID);
if SameText(lPathGUID, cGUID_Root) then
lDisplayName := cRootText
else if SameText(lPathGUID, cGUID_InBox) then
lDisplayName := cInboxText
else if SameText(lPathGUID, cGUID_OutBox) then
lDisplayName := cOutboxText
else if SameText(lPathGUID, cGUID_Draft) then
lDisplayName := cDraftText
else if SameText(lPathGUID, cGUID_SentBox) then
lDisplayName := cSentBoxText
else if SameText(lPathGUID, cGUID_DelBox) then
lDisplayName := cDelBoxText
else
Result := False;
if Result then
begin
AMailPath.PathGUID := lPathGUID;
AMailPath.ParentGUID := cGUID_Root;
AMailPath.OwnerGUID := OperateUser;
AMailPath.DisplayName := lDisplayName;
if SameText(lPathGUID, cGUID_Root) then
AMailPath.ParentPath := ''
else
AMailPath.ParentPath := '\';
AMailPath.FReadOnly := True;
end;
end;
procedure TMailSystem.AddAccount(AMailAccount: TMailAccount);
var
lMailStorage: TMailStorage;
I: Integer;
lMailAccount: TMailAccount;
begin
lMailStorage := TMailStorage.Create(TMailStorageAction.msaSave);
lMailAccount := TMailAccount.create; //创建备用的MailAccount;
lMailAccount.Assign(AMailAccount);
try
Assert(AMailAccount.OwnerID = OperateUser, '不能够操作其他用户的帐号');
lMailStorage.AddAccountCommand(MakeKey(AMailAccount.AccountGUID,
TMailScopeKind.skGUID, OperateUser, ''), AMailAccount);
lMailStorage.Execute;
CheckAccounts;
I := FAccounts.IndexOf(AMailAccount);
if I = -1 then
FAccounts.Add(lMailAccount)
else
if FAccounts[I] <> AMailAccount then
begin
FAccounts.Delete(I); //该操作会释放掉AMailAccount;
FAccounts.Insert(I, lMailAccount);
end;
finally
AMailAccount.Assign(lMailAccount);
lMailStorage.Free;
end;
end;
procedure TMailSystem.SaveAccount(AMailAccount: TMailAccount);
begin
AddAccount(AMailAccount);
end;
procedure TMailSystem.DeleteAccount(AMailAccount: TMailAccount);
var
lMailStorage: TMailStorage;
begin
lMailStorage := TMailStorage.Create(TMailStorageAction.msaDelete);
try
Assert(AMailAccount.OwnerID = OperateUser, '不能够操作其他用户的帐号');
lMailStorage.AddAccountCommand(MakeKey(AMailAccount.AccountGUID,
TMailScopeKind.skGUID, OperateUser, ''), AMailAccount);
lMailStorage.Execute;
CheckAccounts;
FAccounts.Remove(AMailAccount);
finally
lMailStorage.Free;
end;
end;
function TMailSystem.AccountCount: Integer;
begin
CheckAccounts;
Result := FAccounts.Count;
end;
function TMailSystem.FindAccountByGUID(const AccountGUID: string): TMailAccount;
begin
CheckAccounts;
Result := FAccounts.FindAccountByGUID(AccountGUID);
end;
function TMailSystem.FindAccountByAddress(const MailAddress: string): TMailAccount;
begin
CheckAccounts;
Result := FAccounts.FindAccountByAddress(MailAddress);
end;
function TMailSystem.FindAccountByID(const AccountID: string): TMailAccount;
begin
CheckAccounts;
Result := FAccounts.FindAccountByID(AccountID);
end;
function TMailSystem.GetAccounts(const Index: Integer): TMailAccount;
begin
CheckAccounts;
Result := FAccounts.Items[Index];
end;
function TMailSystem.GetOperUser: string;
begin
Result := TSystemCore.Operator.ID;
end;
function TMailSystem.GetOperUserDisplayName: string;
begin
Result := TSystemCore.Operator.DisplayName;
end;
function TMailSystem.MakeKey(const AScope: string;
const AScopeKind: TMailScopeKind; const AOwnerGUID, APathGUID: string): TMailKey;
begin
Result.Scope := AScope;
Result.ScopeKind := AScopeKind;
Result.OwnerGUID := AOwnerGUID;
Result.PathGUID := APathGUID;
end;
function TMailSystem.DoFindMailInfo(const AMailGUID: string): TMailInfo;
var
I: Integer;
begin
if FMailInfoList.Find(AMailGUID, I) then
Result := TMailInfo(FMailInfoList.Objects[I])
else
Result := nil;
end;
function TMailSystem.DoFindMailRef(const AMailGUID,
APath: string): TMailReference;
var
I: Integer;
begin
if FMailRefList.Find(APath + '*' + AMailGUID, I) then
Result := TMailReference(FMailRefList.Objects[I])
else
Result := nil;
end;
procedure TMailSystem.DoSentMail(const AMailGUID: string);
begin
if Assigned(OnSentMail) then
OnSentMail(Self, AMailGUID);
end;
procedure TMailSystem.DoReceiveNewMail(const AMailGUID: string);
begin
if Assigned(OnReceiveNewMail) then
OnReceiveNewMail(Self, AMailGUID);
end;
procedure TMailSystem.AddMailInfo(AMailInfo: TMailInfo);
var
I: Integer;
lObject: TObject;
begin
if FMailInfoList.Find(AMailInfo.MailGUID, I) then
begin
lObject := FMailInfoList.Objects[I];
FMailInfoList.Objects[I] := AMailInfo;
FreeAndNil(lObject);
end
else
FMailInfoList.AddObject(AMailInfo.MailGUID, AMailInfo);
end;
procedure TMailSystem.AddMailRef(var AMailRef: TMailReference);
var
I: Integer;
lObject: TObject;
begin
if FMailRefList.Find(AMailRef.PathGUID + '*' + AMailRef.MailGUID, I) then
begin
if FMailRefList.Objects[I] <> AMailRef then
begin
TMailReference(FMailRefList.Objects[I]).Assign(AMailRef);
//lObject := AMailRef;
//AMailRef := TMailReference(FMailRefList.Objects[I]);
//FreeAndNil(lObject);
end;
end
else
FMailRefList.AddObject(AMailRef.PathGUID + '*' + AMailRef.MailGUID, AMailRef);
DeleteMailInfo(AMailRef.MailGUID);
end;
procedure TMailSystem.DeleteMailInfo(const AMailGUID: string);
var
I: Integer;
lObject: TObject;
begin
if FMailInfoList.Find(AMailGUID, I) then
begin
lObject := FMailInfoList.Objects[I];
FreeAndNil(lObject);
FMailInfoList.Delete(I);
end;
end;
procedure TMailSystem.DeleteMailRef(const AMailGUID, APath: string);
var
I: Integer;
lObject: TObject;
begin
if FMailRefList.Find(APath + '*' + AMailGUID, I) then
begin
lObject := FMailRefList.Objects[I];
FreeAndNil(lObject);
FMailRefList.Delete(I);
end;
end;
procedure TMailSystem.MsgStreamToMail(AMailRef: TMailReference; AMailContent: TStream;
AMailAttachments: TList; AMsgStream: TStream);
var
lMsg: TMessage;
lM2M: TMessage2Mail;
begin
lMsg := TMessage.Create(nil);
try
lM2M := TMessage2Mail.Create;
try
lMsg.LoadFromStream(AMsgStream);
lM2M.MessageToMail(lMsg, AMailRef.MailInfo, AMailcontent, AMailAttachments);
AMailRef.OwnerGUID := OperateUser;
AMailRef.MailInfo.MailGUID := AMailRef.MailGUID;
AMailRef.Size := AMsgStream.Size;
AMailRef.MailInfo.Size := AMailRef.Size;
if Assigned(FindAccountByAddress(AMailRef.MailInfo.From)) then
AMailRef.AccountGUID := FindAccountByAddress(AMailRef.MailInfo.From).AccountGUID;
finally
lM2M.Free;
end;
finally
lMsg.Free;
end;
end;
procedure TMailSystem.MailToMsgStream(AMailInfo: TMailInfo;
AMailContent: TStream; AMailAttachments: TList; AMsgStream: TStream);
var
I: Integer;
lMsg: TMessage;
lM2M: TMessage2Mail;
lAttachStream: TStream;
lMailAttachment: TMailAttachment;
begin
if AMailContent.Size = 0 then
LoadMailContent(AMailInfo.MailGUID, AMailContent);
for I := 0 to AMailInfo.AttachmentInfos.Count - 1 do
begin
lAttachStream := THugeMemoryStream.Create(0);
try
{ 这里不加载附件，使用时在记载，结构不好 lMailAttachment := TMailAttachment.Create;
try
//必须加1，因为0号附件是邮件体
lMailAttachment.Index := I + 1;
LoadMailAttachment(AMailInfo.MailGUID, lMailAttachment);
if lMailAttachment.Content.Size > 0 then
lAttachStream.CopyFrom(lMailAttachment.Content, 0);
finally
lMailAttachment.Free;
end;}
AMailAttachments.Add(lAttachStream);
except
lAttachStream.Free;
raise;
end;
end;
lM2M := TMessage2Mail.Create;
try
lMsg := TMessage.Create(nil);
try
AMailContent.Position := 0;
lM2M.MailToMessage(AMailInfo, AMailContent, AMailAttachments, lMsg);
lMsg.SaveToStream(AMsgStream);
finally
lMsg.Free;
end;
finally
lM2M.Free;
end;
end;
static function TMailSystem.UnloadStreamHeader: string;
begin
Result := '?Unload.Stream?'
end;
procedure TMailSystem.Send;
var
I: Integer;
lMailInfo: TMailInfo;
lStrings: TStrings;
begin
lStrings := TStringList.Create;
try
for I := 0 to OutMails.Count - 1 do
begin
lMailInfo := FindMailInfo(OutMails[I]);
if lMailInfo <> nil then
begin
//if (lMailRef.State and msInternal) = msInternal then
//if (lMailRef.State and msInternal) <> msInternal then//SendExternalMail
lStrings.Add(OutMails[I]);
end;
end;
Send(lStrings);
finally
lStrings.Free;
end;
end;
procedure TMailSystem.Send(MailList: TStrings);
var
I: Integer;
begin
if SendMsgExchg.Sending or ReceiveMsgExchg.Receiving then
exit;
MailSending.Clear;
SendMsgExchg.SMTPMessages.Clear;
for I := 0 to MailList.Count - 1 do
Send(MailList[I], MailList.Count, I + 1);
end;
procedure TMailSystem.Send(const AMailGUID: string; const AMailCount, AMailIndex: Integer);
var
ExternalSenders, InternalSenders: String;
I: Integer;
lMailRef: TMailReference;
lMailInfo: TMailInfo;
begin
//关于邮件发送的说明
//1、首先要解析接收者，分拣为内部用户和外部用户
//2、发送内部邮件（假定不会出现发送失败）
//3、发送外部邮件，将其交送给内部的Exchange，发送结束后，无论是否成功都显示发送成功
//4、如果外部邮件发送失败，就将发送消息和失败的用户信息等组装成一封发送错误的邮件返回给用户
lMailInfo := FindMailInfo(AMailGUID);
if lMailInfo <> nil then
begin
TIBMailConst.SplitSenders(lMailInfo.Tos, ExternalSenders, InternalSenders);
TIBMailConst.SplitSenders(lMailInfo.Cc, ExternalSenders, InternalSenders);
TIBMailConst.SplitSenders(lMailInfo.Bcc, ExternalSenders, InternalSenders);
if InternalSenders <> '' then
SendInternalMail(AMailGUID, InternalSenders, AMailCount, AMailIndex);
if ExternalSenders <> '' then
SendExternalMail(AMailGUID, ExternalSenders);
if ExternalSenders = '' then
begin
I := OutMails.IndexOf(AMailGUID);
if I <> -1 then
OutMails.Delete(I);
DoSentMail(AMailGUID);
end;
end;
end;
procedure TMailSystem.StartReceiveMail(AccountGUIDs: TStrings);
var
I: Integer;
lAccount: TMailAccount;
begin
if SendMsgExchg.Sending or ReceiveMsgExchg.Receiving then
Exit;
ReceiveInternalMail;
ReceiveMsgExchg.POPAccounts.Clear;
for I := 0 to AccountGUIDs.Count - 1 do
begin
lAccount := FindAccountByGUID(AccountGUIDs.Strings[I]);
if Assigned(lAccount) then
ReceiveMsgExchg.POPAccounts.Add(lAccount.POPHost, lAccount.UserID,
lAccount.Password, lAccount.POPPort, lAccount.DeleteOnRetrieve);
end;
//ReceiveMsgExchg.Active := True;
end;
procedure TMailSystem.SendExternalMail(const AMailGUID, ASenders: string);
var
lAccount: TMailAccount;
lStream: TStream;
lMailContent: TStream;
lMailAttachments: TObjectList;
lMailInfo: TMailInfo;
begin
lMailInfo := FindMailInfo(AMailGUID);
if lMailInfo <> nil then
begin
lAccount := FindAccountByAddress(lMailInfo.From);
if lAccount <> nil then
begin
lMailAttachments := TObjectList.Create(True);
lMailContent := THugeMemoryStream.Create(0);
lStream := THugeMemoryStream.Create(0);
try
MailToMsgStream(lMailInfo, lMailContent, lMailAttachments, lStream);
lStream.Position := 0;
if lAccount.Verify then
begin
if lAccount.DifferPOP then
SendMsgExchg.SMTPMessages.Add(lAccount.VerifyAccount,
lAccount.VerifyPassword, lAccount.SMTPHost,
lMailInfo.From, ASenders, lStream, lAccount.SMTPPort)
else
SendMsgExchg.SMTPMessages.Add(lAccount.UserID, lAccount.Password,
lAccount.SMTPHost, lMailInfo.From, ASenders, lStream, lAccount.SMTPPort);
end
else
SendMsgExchg.SMTPMessages.Add(lAccount.SMTPHost, lMailInfo.From,
ASenders, lStream, lAccount.SMTPPort);
finally
lStream.Free;
lMailContent.Free;
lMailAttachments.Free;
end;
MailSending.Add(lMailInfo.MailGUID);
end;
end;
end;
procedure TMailSystem.BeforeReceivMail(const AccountGUID, UIDL: String;
var Receive: Boolean);
var
lAccount: TMailAccount;
begin
lAccount := FindAccountByGUID(AccountGUID);
if Assigned(lAccount) then
Receive := not SearcbMailUIDL(UIDL, OperateUser, nil)
else
Receive := False;
end;
procedure DoSetNewMailRefProperties(AMailRef: TMailReference; AAccount: TMailAccount);
begin
AMailRef.OwnerGUID := TMailLibrary.GetOwnerID;
AMailRef.PathGUID := cGUID_InBox;
AMailRef.Time := SysUtils.Now;
AMailRef.State := msReceived;
if AAccount <> nil then
AMailRef.AccountGUID := AAccount.AccountGUID;
end;
procedure TMailSystem.ReceiveMail(const AccountGUID: String;
AStream: TStream; const UIDL: String; var Delete: Boolean);
var
lMsg: TMessage;
lM2M: TMessage2Mail;
lMailRef: TMailReference;
lMailContent: TStream;
lMailAttachments: TList;
lAccount: TMailAccount;
lMailRefList: TStringList;
begin
lAccount := FindAccountByGUID(AccountGUID);
lMailRef := TMailReference.Create;
try
lMsg := TMessage.Create(nil);
lMailRefList := TStringList.Create;
try
if SearcbMailUIDL(UIDL, '', lMailRefList) then
begin
lMailRef.Assign(TMailReference(lMailRefList.Objects[0]));
DoSetNewMailRefProperties(lMailRef, lAccount);
//保存邮件引用
SaveMailRef(lMailRef);
end
else
begin
lM2M := TMessage2Mail.Create;
lMailContent := THugeMemoryStream.Create(0);
lMailAttachments := TObjectList.Create(True);
try
lMailRef.MailGUID := CreateGUIDStr;
lMailRef.MailInfo.MailGUID := lMailRef.MailGUID;
lMailRef.MailInfo.UIDL := UIDL;
lMsg.LoadFromStream(AStream);
lM2M.MessageToMail(lMsg, lMailRef.MailInfo, lMailContent, lMailAttachments);
lMailRef.MailGUID:= lMailRef.MailInfo.MailGUID;
lMailRef.Size := AStream.Size;
lMailRef.MailInfo.Size := lMailRef.Size;
DoSetNewMailRefProperties(lMailRef, lAccount);
//保存邮件实体和引用
SaveMail(lMailRef, lMailContent, lMailAttachments);
finally
lMailContent.Free;
lMailAttachments.Free;
lM2M.Free;
end;
end;
DoReceiveNewMail(lMailRef.MailGUID);
finally
lMailRefList.Free;
lMsg.Free;
end;
except
lMailRef.Free;
raise;
end;
end;
procedure TMailSystem.SentMail(MailIndex: Integer);
var
S: string;
I: Integer;
lMailRef: TMailReference;
begin
if MailIndex >= 0 then //在发送
begin
S := MailSending.Strings[MailIndex];
{lMailRef := FindMailRef(S, cGUID_OutBox);
if lMailRef <> nil then
begin
lMailRef.State := lMailRef.State or msSent;
lMailRef.PathGUID := cGUID_SentBox;
SaveMailRef(lMailRef);
end;
}
I := OutMails.IndexOf(S);
if I <> -1 then
OutMails.Delete(I);
DoSentMail(S);
end;
end;
procedure TMailSystem.ReceiveInternalMail;
var
I, J: Integer;
lMailRef: TMailReference;
lStrings: TStrings;
lMailRefList: TObjectList;
begin
lStrings := TStringList.Create;
lMailRefList := TObjectList.Create(False);
try
if Assigned(LoadFolderMails) then
LoadFolderMails(Self, lStrings, cGUID_InBox)
else
raise Exception.Create('没有提供取指定目录下面邮件的方法');
for I := 0 to lStrings.Count - 1 do
begin
lMailRef := TMailReference(lStrings.Objects[I]);
J := lMailRef.State;
if (J and msLoaded) = msLoaded then
begin
J := J xor msLoaded;
lMailRef.State := J or msReceived;
lMailRefList.Add(lMailRef);
end;
end;
if lMailRefList.Count > 0 then
SaveMailRefList(lMailRefList);
for I := 0 to lMailRefList.Count - 1 do
DoReceiveNewMail(TMailReference(lMailRefList[I]).MailGUID);
finally
lStrings.Free;
lMailRefList.Free;
end;
end;
procedure TMailSystem.SendInternalMail(const AMailGUID, ASenders: string;
const AMailCount, AMailIndex: Integer);
var
I: Integer;
lMailRefList: TObjectList;
lMailRef: TMailReference;
lSenders: TStrings;
lSize: Integer;
begin
lSenders := TStringList.Create;
try
lSenders.Text := ASenders;
lMailRefList := TObjectList.Create(True);
try
lMailRef := FindMailRef(AMailGUID, cGUID_OutBox);
lSize := lMailRef.Size;
for I := 0 to lSenders.Count - 1 do
begin
lMailRef := TMailReference.Create;
lMailRef.OwnerGUID := UpperCase(lSenders[I]);
lMailRef.MailGUID := AMailGUID;
lMailRef.PathGUID := cGUID_InBox;
lMailRef.Time := SysUtils.Now;
lMailRef.State := msInternal or msLoaded;
lMailRef.Size := lSize;
lMailRef.MailInfo.Size := lSize;
lMailRef.MailInfo.From := 'SMP';
lMailRefList.Add(lMailRef);
end;
SaveMailRefList(lMailRefList);
finally
lMailRefList.Free;
end;
finally
lSenders.Free;
end;
if Assigned(OnSendInternalMail) then
OnSendInternalMail(Self, AMailCount, AMailIndex);
end;
procedure TMailSystem.BeforeStartMailExchange;
begin
if Assigned(OnBeforeStartMailExchange) then
OnBeforeStartMailExchange(Self);
end;
procedure TMailSystem.StartMailExchange(const AReceive, ASend: Boolean);
begin
if ASend then
SendMsgExchg.Active := True;
if AReceive then
ReceiveMsgExchg.Active := True;
end;
{ TMailMoveRefStorageCommand }
constructor TMailMoveRefStorageCommand.Create(const ANewPath: string);
begin
inherited Create;
FNewPath := ANewPath;
end;
function TMailMoveRefStorageCommand.GetDataSetIndex: Integer;
begin
Result := -1;
end;
{ TMailMovePathStorageCommand }
constructor TMailMovePathStorageCommand.Create(const AOldParent, ANewParent,
AOldPath, ANewPath: string);
begin
inherited Create;
FOldParent := AOldParent;
FNewParent := ANewParent;
FOldPath := AOldPath;
FNewPath := ANewPath;
end;
function TMailMovePathStorageCommand.GetDataSetIndex: Integer;
begin
Result := -1;
end;
{ TMailAccountStorageCommand }
function TMailAccountStorageCommand.GetDataSetIndex: Integer;
begin
Result := MAS;
end;
procedure TMailAccountStorageCommand.SetAccount(ADataSet: TDataSet;
AMailAccount: TMailAccount);
var
lStream: TStream;
begin
AMailAccount.AccountGUID := ADataSet.FieldByName('FGUID').AsString;
AMailAccount.AccountID := ADataSet.FieldByName('FACCOUNTID').AsString;
AMailAccount.OwnerID := ADataSet.FieldByName('FOWNERGUID').AsString;
AMailAccount.MailAddress := ADataSet.FieldByName('FMAILADDRESS').AsString;
lStream := THugeMemoryStream.Create(0);
try
TBlobField(ADataSet.FieldByName('FPROPERTY')).SaveToStream(lStream);
lStream.Position := 0;
AMailAccount.LoadPropertiesFromStream(lStream);
finally
lStream.Free;
end;
end;
procedure TMailAccountStorageCommand.DoLoad(AStorage: TMailStorage);
begin
SetAccount(AStorage.DataSets[GetDataSetIndex], FMailAccount);
end;
procedure TMailAccountStorageCommand.DoSave(AStorage: TMailStorage);
var
lDataSet: TDataSet;
lStream: TStream;
begin
if Key.ScopeKind = TMailScopeKind.skGUID then
begin
lDataSet := AStorage.DataSets[GetDataSetIndex];
if lDataSet.Locate('FGUID', Key.Scope, []) then
lDataSet.Edit
else
begin
lDataSet.Append;
lDataSet.FieldByName('FCLIENTACCOUNT').AsString := BizSys.BizSystem.ClientAccount;
end;
lDataSet.FieldByName('FGUID').AsString := FMailAccount.AccountGUID;
lDataSet.FieldByName('FACCOUNTID').AsString := FMailAccount.AccountID;
lDataSet.FieldByName('FOWNERGUID').AsString := FMailAccount.OwnerID;
lDataSet.FieldByName('FMAILADDRESS').AsString := FMailAccount.MailAddress;
lStream := THugeMemoryStream.Create(0);
try
FMailAccount.SavePropertiesToStream(lStream);
TBlobField(lDataSet.FieldByName('FPROPERTY')).LoadFromStream(lStream);
finally
lStream.Free;
end;
lDataSet.Post;
end
else
Assert(False, '没有支持的方法');
end;
constructor TMailAccountStorageCommand.Create(AMailAccount: TMailAccount);
begin
inherited Create;
FMailAccount := AMailAccount;
end;
{ TMailMulitAccountStorageCommand }
procedure TMailMulitAccountStorageCommand.DoLoad(AStorage: TMailStorage);
var
lDataSet: TDataSet;
lMailAccount: TMailAccount;
begin
lDataSet := AStorage.DataSets[GetDataSetIndex];
lDataSet.First;
while not lDataSet.Eof do
begin
lMailAccount := TMailAccount.Create;
try
SetAccount(lDataSet, lMailAccount);
FMailAccountList.AddObject(lMailAccount.AccountID, lMailAccount);
lDataSet.Next;
except
lMailAccount.Free;
raise;
end;
end;
end;
procedure TMailMulitAccountStorageCommand.DoSave(AStorage: TMailStorage);
begin
Assert(False, '不支持的动作');
end;
constructor TMailMulitAccountStorageCommand.Create(AMailAccountList: TStrings);
begin
inherited Create;
FMailAccountList := AMailAccountList;
end;
type
TAccountWrapper = class(TComponent)
private
FAccount: TMailAccount;
//published
property Account: TMailAccount read FAccount write FAccount;
end;
{ TMailAccount }
constructor TMailAccount.Create;
begin
inherited;
AccountGUID := CreateGUIDStr;
AccountID := '';
OwnerID := '';
MailAddress := '';
POPHost := '';
FPOPPort := 110;
SMTPHost := '';
FSMTPPort := 25;
UserID := '';
Password := '';
DifferPOP := False;
Verify := False;
VerifyAccount := '';
VerifyPassword := '';
DeleteOnRetrieve := False;
IsDefault := False;
end;
destructor TMailAccount.Destroy;
begin
inherited;
end;
procedure TMailAccount.Assign(Source: TPersistent);
var
lMailAccount: TMailAccount;
begin
if Source is TMailAccount then
begin
lMailAccount := TMailAccount(Source);
AccountGUID := lMailAccount.AccountGUID;
AccountID := lMailAccount.AccountID;
MailAddress := lMailAccount.MailAddress;
OwnerID := lMailAccount.OwnerID;
POPHost := lMailAccount.POPHost;
POPPort := lMailAccount.POPPort;
SMTPHost := lMailAccount.SMTPHost;
SMTPPort := lMailAccount.SMTPPort;
UserID := lMailAccount.UserID;
Password := lMailAccount.Password;
DifferPOP := lMailAccount.DifferPOP;
Verify := lMailAccount.Verify;
VerifyAccount := lMailAccount.VerifyAccount;
VerifyPassword := lMailAccount.VerifyPassword;
IsDefault := lMailAccount.IsDefault;
DeleteOnRetrieve := lMailAccount.DeleteOnRetrieve;
end
else
inherited Assign(Source);
end;
procedure TMailAccount.LoadPropertiesFromStream(AStream: TStream);
var
lIniFile: TStreamXMLIniFile;
begin
AStream.Position := 0;
lIniFile := TStreamXMLIniFile.Create(AStream);
try
//将Ini中的值赋给对象的属性
AccountGUID := lIniFile.ReadString(cAccountSection, 'AccountGUID', '');
AccountID := lIniFile.ReadString(cAccountSection, 'AccountID', '');
OwnerID := lIniFile.ReadString(cAccountSection, 'OwnerID', '');
MailAddress := lIniFile.ReadString(cAccountSection, 'MailAddress', '');
POPHost := lIniFile.ReadString(cAccountSection, 'POPHost', '');
POPPort := lIniFile.ReadInteger(cAccountSection, 'POPPort', 110);
SMTPHost := lIniFile.ReadString(cAccountSection, 'SMTPHost', '');
SMTPPort := lIniFile.ReadInteger(cAccountSection, 'SMTPPort', 25);
UserID := lIniFile.ReadString(cAccountSection, 'UserID', '');
Password := lIniFile.ReadString(cAccountSection, 'Password', '');
DifferPOP := lIniFile.ReadBool(cAccountSection, 'DifferPOP', False);
Verify := lIniFile.ReadBool(cAccountSection, 'Verify', True);
VerifyAccount := lIniFile.ReadString(cAccountSection, 'VerifyAccount', '');
VerifyPassword := lIniFile.ReadString(cAccountSection, 'VerifyPassword', '');
DeleteOnRetrieve := lIniFile.ReadBool(cAccountSection, 'DeleteOnRetrieve', True);
IsDefault := lIniFile.ReadBool(cAccountSection, 'IsDefault', True);
finally
lIniFile.Free;
end;
end;
procedure TMailAccount.SavePropertiesToStream(AStream: TStream);
var
lIniFile: TStreamXMLIniFile;
begin
lIniFile := TStreamXMLIniFile.Create(AStream);
try
//将对象属性的值赋给Ini
lIniFile.WriteString(cAccountSection, 'AccountGUID', AccountGUID);
lIniFile.WriteString(cAccountSection, 'AccountID', AccountID);
lIniFile.WriteString(cAccountSection, 'OwnerID', OwnerID);
lIniFile.WriteString(cAccountSection, 'MailAddress', MailAddress);
lIniFile.WriteString(cAccountSection, 'POPHost', POPHost);
lIniFile.WriteInteger(cAccountSection, 'POPPort', POPPort);
lIniFile.WriteString(cAccountSection, 'SMTPHost', SMTPHost);
lIniFile.WriteInteger(cAccountSection, 'SMTPPort', SMTPPort);
lIniFile.WriteString(cAccountSection, 'UserID', UserID);
lIniFile.WriteString(cAccountSection, 'Password', Password);
lIniFile.WriteBool(cAccountSection, 'DifferPOP', DifferPOP);
lIniFile.WriteBool(cAccountSection, 'Verify', Verify);
lIniFile.WriteString(cAccountSection, 'VerifyAccount', VerifyAccount);
lIniFile.WriteString(cAccountSection, 'VerifyPassword', VerifyPassword);
lIniFile.WriteBool(cAccountSection, 'DeleteOnRetrieve', DeleteOnRetrieve);
lIniFile.WriteBool(cAccountSection, 'IsDefault', IsDefault);
finally
lIniFile.Free;
end;
end;
{ TMailAccounts }
function TMailAccounts.Add(AMailAccount: TMailAccount): Integer;
begin
Result := inherited Add(AMailAccount);
end;
procedure TMailAccounts.Clear;
{var
I: Integer; }
begin
{ for I := 0 to Count - 1 do
Delete(I); }
inherited Clear;
end;
function TMailAccounts.Extract(Item: TMailAccount): TMailAccount;
begin
Result := TMailAccount(inherited Extract(Item));
end;
function TMailAccounts.First: TMailAccount;
begin
Result := TMailAccount(inherited First);
end;
function TMailAccounts.GetItems(Index: Integer): TMailAccount;
begin
Result := TMailAccount(inherited Items[Index]);
end;
function TMailAccounts.IndexOf(AMailAccount: TMailAccount): Integer;
begin
Result := inherited Indexof(AMailAccount);
end;
procedure TMailAccounts.Insert(Index: Integer; AMailAccount: TMailAccount);
begin
inherited Insert(Index, AMailAccount);
end;
function TMailAccounts.Last: TMailAccount;
begin
Result := TMailAccount(inherited Last);
end;
function TMailAccounts.Remove(AMailAccount: TMailAccount): Integer;
begin
Result := inherited Remove(AMailAccount);
end;
procedure TMailAccounts.SetItems(Index: Integer;
AMailAccount: TMailAccount);
begin
inherited Items[Index] := AMailAccount;
end;
function TMailAccounts.FindAccountByAddress(
const MailAddress: string): TMailAccount;
var
I: Integer;
begin
Result := nil;
for I := 0 to Count - 1 do
if Items[I].MailAddress = MailAddress then
begin
Result := Items[I];
Exit;
end;
end;
function TMailAccounts.FindAccountByGUID(
const AccountGUID: string): TMailAccount;
var
I: Integer;
begin
Result := nil;
for I := 0 to Count - 1 do
if Items[I].AccountGUID = AccountGUID then
begin
Result := Items[I];
Exit;
end;
end;
function TMailAccounts.FindAccountByID(
const AccountID: string): TMailAccount;
var
I: Integer;
begin
Result := nil;
for I := 0 to Count - 1 do
if Items[I].AccountID = AccountID then
begin
Result := Items[I];
Exit;
end;
end;
{ TMessage2Mail }
function ConvertPriority(const APriority: string): Integer;
begin
Result := StrToIntDef(APriority, -1);
if Result = -1 then
Result := StrToIntDef(Copy(APriority, 1, Pos(' ', APriority) - 1), 3);
end;
procedure TMessage2Mail.MessageToMail(AMessage: TMessage; AMailInfo: TMailInfo;
AMailContent: TStream; AMailAttachments: TList);
var
lHasAttach: Boolean;
begin
AMailInfo.From := AMessage.From;
AMailInfo.Tos := AMessage.SendTo;
AMailInfo.Cc := AMessage.CC;
AMailInfo.Bcc := AMessage.BCC;
AMailInfo.Subject := AMessage.Subject;
AMailInfo.Date := TIBMailConst.MailDateToDelphiDate(AMessage.Date);
AMailInfo.Priority := ConvertPriority(AMessage.Priority);
ToMailAttachments(AMessage, lHasAttach, AMailAttachments, AMailInfo.AttachmentInfos);
AMailInfo.HasAttach := lHasAttach;
AMessage.SaveToStream(AMailContent);
end;
procedure TMessage2Mail.MailToMessage(AMailInfo: TMailInfo; AMailContent: TStream;
AMailAttachments: TList; AMessage: TMessage);
var
I: Integer;
S: string;
lStream: TStream;
begin
// Assert(AMailAttachments.Count = AMailInfo.AttachmentInfos.Count, '');
AMessage.LoadFromStream(AMailContent);
for I := 0 to AMailAttachments.Count - 1 do
begin
lStream := TStream(AMailAttachments[I]);
lStream.Position := 0;
S := AMailInfo.AttachmentInfos[I];
S := Copy(S, Pos('*', S) + 1, MaxInt);
AMessage.AddAttachByIndex(S, I);
// AMessage.AddAttachFromStream(S, lStream);
end;
end;
procedure TMessage2Mail.ToMailAttachments(AMessage: TMessage;
var HasAttach: Boolean; Attachments: TList; AttachmentInfos: TStrings);
var
I: Integer;
lStrings: TStrings;
lStream: TStream;
begin
HasAttach := False;
lStrings := TStringList.Create;
try
AMessage.GetAttachFileNames(lStrings);
Attachments.Clear;
AttachmentInfos.Clear;
for I := 0 to lStrings.Count - 1 do
begin
lStream := THugeMemoryStream.Create(0);
TMessageItem(lStrings.Objects[I]).GetContent(lStream);
Attachments.Add(lStream);
AttachmentInfos.Add(Format('%d*%s', [lStream.Size, lStrings.Strings[I]]));
HasAttach := True;
AMessage.DeleteAttachment(lStrings.Strings[I]);
end;
finally
lStrings.Free;
end;
end;
{ TMailSetting }
procedure TMailSetting.LoadFromFile(const FileName: string);
var
lIni: TIniFile;
lStream: TStream;
begin
lIni := TIniFile.Create(FileName);
try
lStream := THugeMemoryStream.Create(0);
try
lIni.ReadBinaryStream(TMailLibrary.GetOwnerID, ValueName, lStream);
lStream.Position := 0;
LoadFromStream(lStream);
finally
lStream.Free;
end;
finally
lIni.Free;
end;
end;
procedure TMailSetting.SaveToFile(const FileName: string);
var
lIni: TIniFile;
lStream: TStream;
begin
try
lIni := TIniFile.Create(FileName);
try
lStream := THugeMemoryStream.Create(0);
try
SaveToStream(lStream);
lStream.Position := 0;
lIni.WriteBinaryStream(TMailLibrary.GetOwnerID, ValueName, lStream);
finally
lStream.Free;
end;
finally
lIni.Free;
end;
except
//nothing todo
end;
end;
constructor TSendedMailState.Create(const AMailGUID: String);
begin
inherited Create;
FMailGUID := AMailGUID;
end;
function TSendedMailState.getState: String;
var
lReaded, lUnReaded: integer;
begin
lReaded := 0;
lUnReaded := 0;
with TQuery.Create(nil) do
try
ConnectionString := cConnectionStr;
if Connection.Meta.DataProvider = BizSchemaTypes.cDriver_ORACLE then
CommandText := 'SELECT * FROM TMAILREFERENCE WHERE (BITAND(FSTATE,2) <> 2) AND FGUID = ' + SysUtils.QuotedStr(FMAILGUID)
else
CommandText := 'SELECT * FROM TMAILREFERENCE WHERE ((FSTATE&2) <> 2) AND FGUID = ' + SysUtils.QuotedStr(FMAILGUID);
Open;
while not EOF do
begin
if (FieldByName('FSTATE').AsInteger and msReaded) = msReaded then
Inc(lReaded)
else
Inc(lUnReaded);
if (lReaded > 0) and (lUnReaded > 0) then
begin
Result := cDepartReaded; //部分已读
Exit;
end;
Next;
end;
if lReaded > 0 then
Result := cAllReaded;//全部已读
if lUnReaded > 0 then
Result := cNoOneReaded; //全部未读
finally
Free;
end;
end;
function TSendedMailState.getHints: String;
var
lReaded, lUnReaded: TStrings;
I: Integer;
lReturn, lPersonName: String;
lPerson: TPerson;
begin
lReaded := TStringList.Create;
lUnReaded := TStringList.Create;
with TQuery.Create(nil) do
try
ConnectionString := cConnectionStr;
if SameText(Connection.Meta.DataProvider, cDriver_ORACLE) then
CommandText := 'SELECT * FROM TMAILREFERENCE WHERE (BITAND(FSTATE, 2) <> 2) AND FGUID = ' + SysUtils.QuotedStr(FMAILGUID)
else
CommandText := 'SELECT * FROM TMAILREFERENCE WHERE ((FSTATE & 2) <> 2) AND FGUID = ' + SysUtils.QuotedStr(FMAILGUID);
Open;
while not EOF do
begin
lPersonName := FieldByName('FOWNERGUID').AsString;
lPerson := OrgSys.OrgSystem.FindPerson(FieldByName('FOWNERGUID').AsString);
if Assigned(lPerson) then
lPersonName := lPerson.DisplayName;
if (FieldByName('FSTATE').AsInteger and msReaded) = msReaded then
lReaded.Add(lPersonName)
else
lUnReaded.Add(lPersonName);
Next;
end;
if lReaded.Count > 0 then
Result := '已读人数：' + SysUtils.IntToStr(lReaded.Count) + #13 +#10;
if lUnReaded.Count > 0 then
Result := Result + '未读人数：' + SysUtils.IntToStr(lUnReaded.Count) + #13 + #10;
Result := Result + #13 + #10;
if lReaded.Count > 0 then
Result := Result + '已读：';
lReturn := ''; //计算换行
for I := 0 to lReaded.Count - 1 do
begin
if I = lReaded.Count - 1 then
Result := Result + lReaded[I]
else
Result := Result + lReaded[I] + ',' ;
lReturn := lReturn + lReaded[I] + ',';
if(I > 0) and (lReturn.Length >= 36) then
begin
lReturn := '';
Result := Result + #13 + #10 +' ';
end;
end;
Result := Result + #13 + #10;
if lUnReaded.Count > 0 then
Result := Result + '未读：';
lReturn := ''; //计算换行
for I := 0 to lUnReaded.Count - 1 do
begin
if I = lUnReaded.Count - 1 then
Result := Result + lUnReaded[I]
else
Result := Result + lUnReaded[I] + ',';
lReturn := lReturn + lUnReaded[I] + ',';
if (I>0) and (lReturn.Length >= 36) then
begin
Result := Result + #13 + #10 + ' ';
lReturn := '';
end;
end;
finally
Free;
lUnReaded.Free;
lReaded.Free;
end;
end;
end. |
发表于 2008-2-29 09:32:17
楼主