unit MessagesManagerFrm; interface uses TransmitDirection, FileTransmitterObjective, md5, MyInputBoxFrm, FileTransmitter, DownloadFileFromWeb,ShellAPI, Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, StrUtils, xFonts, Dialogs, ExtCtrls, ActnCtrls, ActnMan, ActnMenus, ToolWin, ComCtrls, ImgList, MSHTML, Menus, ActnList, StdStyleActnCtrls, Buttons, StdCtrls, OleCtrls, SHDocVw, RealICQClient, RealICQUtils, RealICQSkinFrm, ShareUtils, RealICQContacterTreeView, RealICQModel, RealICQSpeedButton, RealICQButton, FileCtrl; type TMessagesManagerForm = class(TRealICQSkinForm) pnlClient: TPanel; Splitter1: TSplitter; CoolBar1: TCoolBar; Panel2: TPanel; Label1: TLabel; Label2: TLabel; btSearch: TSpeedButton; btRefresh: TSpeedButton; btDel: TSpeedButton; Bevel1: TBevel; cbSearchRange: TComboBox; edKeyword: TEdit; pnlLeft: TPanel; tvSenders: TTreeView; pnlRight: TPanel; Splitter2: TSplitter; lvContents: TListView; pnlContent: TPanel; pnlHeaders: TPanel; lblDate: TLabel; lblTime: TLabel; lblSender: TLabel; ScrollBox1: TScrollBox; WebBrowser: TWebBrowser; pnlPageSet: TPanel; btNext: TSpeedButton; btLast: TSpeedButton; btFirst: TSpeedButton; btPrev: TSpeedButton; lblPages: TLabel; Label3: TLabel; cbPageSize: TComboBox; ImgLstNodeImage: TImageList; ppTreeNode: TPopupMenu; miDelMessageHistory: TMenuItem; ppListView: TPopupMenu; MenuItem1: TMenuItem; SpeedButton1: TSpeedButton; SpeedButton2: TSpeedButton; btSeeInfo: TRealICQButton; btExportAllMsg: TSpeedButton; procedure lvContentsColumnClick(Sender: TObject; Column: TListColumn); procedure lvContentsClick(Sender: TObject); procedure btSeeInfoClick(Sender: TObject); procedure SpeedButton2Click(Sender: TObject); procedure SpeedButton1Click(Sender: TObject); procedure lvContentsMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure ppListViewPopup(Sender: TObject); procedure btNextClick(Sender: TObject); procedure btLastClick(Sender: TObject); procedure btPrevClick(Sender: TObject); procedure btFirstClick(Sender: TObject); procedure btDelClick(Sender: TObject); procedure btSearchClick(Sender: TObject); procedure btRefreshClick(Sender: TObject); procedure lvContentsDblClick(Sender: TObject); procedure WebBrowserDocumentComplete(ASender: TObject; const pDisp: IDispatch; var URL: OleVariant); procedure lvContentsChange(Sender: TObject; Item: TListItem;Change: TItemChange); procedure tvSendersChange(Sender: TObject; Node: TTreeNode); procedure lvContentsResize(Sender: TObject); procedure tvSendersGetSelectedIndex(Sender: TObject; Node: TTreeNode); procedure tvSendersCustomDrawItem(Sender: TCustomTreeView; Node: TTreeNode;State: TCustomDrawState; var DefaultDraw: Boolean); procedure FormClose(Sender: TObject; var Action: TCloseAction); procedure FormDestroy(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); procedure ppTreeNodePopup(Sender: TObject); procedure tvSendersMouseUp(Sender: TObject; Button: TMouseButton;Shift: TShiftState; X, Y: Integer); procedure miDelMessageHistoryClick(Sender: TObject); procedure cbPageSizeChange(Sender: TObject); procedure WebBrowserBeforeNavigate2(ASender: TObject;const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,Headers: OleVariant; var Cancel: WordBool); procedure btExportAllMsgClick(Sender: TObject); private FBaseURL: string; FRecordCount: Integer; FPageCount: Integer; FPageIndex: Integer; FTeamID: String; FSender: String; FReceiver: String; FFileTransmitter: TFileTransmitter; FDownFile: TDownFile; FDBFile: String; procedure DownFileProgress(ulProgress, ulProgressMax, ulStatusCode: integer; szStatusText: String); procedure DownFileComplete(Source_file, Dest_file:String; blStatus:boolean; ErrMessage:String); procedure LoadTreeViewItems; procedure ClearContents; procedure SetDOMStyle(Doc:IHTMLDocument2); procedure ShowMessages(Messages: TList); procedure LoadMessages; procedure SetPageSetsState; procedure ShowSystemMessages(Messages: TList); procedure LoadSystemMessages; procedure LoadSMSMessages; procedure FileTransmitterCalculatedSpeed(Sender: TObject; ATransmittedSize: Int64); procedure FileTransmitterCompleted(Sender: TObject); protected procedure CreateParams(var Params: TCreateParams); override; public procedure ChangeUIColor(AColor: TColor); override; procedure ShowUsersMessages(ALoginName: String); procedure ShowTeamsMessages(ATeamID: String); function IsDigit(S: String): Boolean; end; var MessagesManagerForm: TMessagesManagerForm; implementation uses MainFrm, RealICQDBHistory, TalkingFrm, SystemMessageFrm, ProcessingFrm, TeamsAdapter, UsersService, FriendsService, FileTransmitAdapter; const UserStateIndex: Integer = 1; TeamStateIndex: Integer = 2; SystemMessageStateIndex: Integer = 3; SearchResultStateIndex: Integer = 4; SMSMessageStateIndex: Integer = 5; {$R *.dfm} {为消息添加字体信息} //------------------------------------------------------------------------------ procedure AddFontStyle(var AMessageContent: String; FontStr: String); var HexString, HTML: String; TextFont: TFont; begin HTML := AMessageContent; TextFont := TFont.Create; try StringToFont(FontStr, TextFont); //设置字体 HexString := IntToHex(TextFont.Color, 6); //获取颜色的16进制格式 HTML := '
' + AMessageContent + '
'; finally TextFont.Free; end; AMessageContent := HTML; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.ChangeUIColor(AColor: TColor); begin inherited ChangeUIColor(AColor); pnlClient.Color := FormColor; btSeeInfo.ChangeUIColor(AColor); end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.btSearchClick(Sender: TObject); var Messages: TList; MessageSearchResult: TMessageSearchResult; Node: TTreeNode; RealICQTeam: TRealICQTeam; RealICQUser: TRealICQUser; iLoop: Integer; AMessageStr, ReceiverName, ALoginName: String; begin if Length(Trim(edKeyword.Text)) = 0 then begin MessageBox(Handle, '请输入关键字', '提示', MB_ICONINFORMATION); Exit; end; ClearContents; Messages := nil; ProcessingForm := TProcessingForm.Create(Self); ProcessingForm.Show; Application.ProcessMessages; Sleep(400); try if cbSearchRange.ItemIndex <= 0 then begin Messages := MainForm.DBHistory.SearchMessage('-1', '','', True, Trim(edKeyword.Text)); end else begin Node := tvSenders.Items.GetFirstNode; while Node <> nil do begin if Node.Text = cbSearchRange.Items.Strings[cbSearchRange.ItemIndex] then begin if Node.StateIndex = UserStateIndex then begin try RealICQUser := Node.Data; if Assigned(RealICQUser) then begin Messages := MainForm.DBHistory.SearchMessage('-1', RealICQUser.LoginName, MainForm.RealICQClient.LoginName, False, Trim(edKeyword.Text)); Break; end; except end; end; if Node.StateIndex = TeamStateIndex then begin try RealICQTeam := Node.Data; if Assigned(RealICQTeam) then begin Messages := MainForm.DBHistory.SearchMessage(RealICQTeam.TeamID, '', '', False, Trim(edKeyword.Text)); Break; end; except end; end; end; Node := Node.GetNext; end; //while end; if Messages = nil then Exit; tvSenders.Items.Item[tvSenders.Items.Count - 1].Selected := True; lvContents.Items.BeginUpdate; try for iLoop := 0 to Messages.Count - 1 do begin MessageSearchResult := Messages[iLoop]; with lvContents.Items.Add do begin try if StrToInt(MessageSearchResult.TeamID) <= 0 then StateIndex := UserStateIndex else StateIndex := TeamStateIndex; except StateIndex := TeamStateIndex; end; if StateIndex = UserStateIndex then begin if (MessageSearchResult.TeamID <= '-2') and (MessageSearchResult.TeamID <> '-5') then ImageIndex := 8 else begin ImageIndex := 1; end; end else ImageIndex := 5; RealICQUser:= TUsersService.GetUsersService.GetOrRequestUser(MessageSearchResult.Sender); ALoginName := RealICQUser.LoginName; if Pos('-', ALoginName) > 0 then ALoginName := Copy(ALoginName, Pos('-', ALoginName) + 1, Length(ALoginName)); if (Length(RealICQUser.DisplayName) = 0) then Caption := ALoginName else Caption := RealICQUser.DisplayName + '<' + ALoginName + '>'; if MessageSearchResult.TeamID <= '-2' then begin RealICQUser:= TUsersService.GetUsersService.GetOrRequestUser(MessageSearchResult.Receiver); ALoginName := RealICQUser.LoginName; if Pos('-', ALoginName) > 0 then ALoginName := Copy(ALoginName, Pos('-', ALoginName) + 1, Length(ALoginName)); if (Length(RealICQUser.DisplayName) = 0) then ReceiverName := ALoginName else ReceiverName := RealICQUser.DisplayName + '<' + ALoginName + '>'; Caption := Caption + ' -> ' + ReceiverName; end; SubItems.Add(DateToStr(MessageSearchResult.SendDateTime)); SubItems.Add(TimeToStr(MessageSearchResult.SendDateTime)); AMessageStr := MessageSearchResult.MessageStr; GetFaces2(AMessageStr, False); SubItems.Add(AMessageStr); Data := MessageSearchResult; end; end; finally lvContents.Items.EndUpdate; Messages.Free; end; finally pnlPageSet.Visible := False; ProcessingForm.Free; end; end; //------------------------------------------------------------------------------ //变量S为要判断的字符串,返回true则正确 function TMessagesManagerForm.IsDigit(S:String):Boolean; var i,j:integer; begin Result:=True; j :=0 ; for i :=1 to length(s) do begin if not (s[i] in ['0'..'9','.'])then //判断字符串每个字符即s[i],是否为"0"到'9"数字及".' Result:=False; if s[i]='.' Then //统计字符串中"."的个数 j:=j+1; end; if j > 1 then //字符串中"."的个数大于1 Result:=False; if (s[1]='.') or (s[length(s)]='.') then //字符串中"."的在最前面和最后面 Result:=False; //增加, 字符串中"."的位置之前有两个"0"判断 s:=copy(s,1, pos('.', S)-1); //取字符串中"."的位置之前字符 j:=0; for i:=1 to length(s) do begin if s[i]='0' then j:=j+1; end; if j > 1 then //字符串中"."的位置之前有两个"0" Result:=False; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.btExportAllMsgClick(Sender: TObject); var iLoop, jLoop: Integer; RootPath, FileName, StrLogin,StrSender, StrReceiver, StrTmp: string; GroupList, UserList, TmpList: TStringList; MessageSearchResult: TMessageSearchResult; Messages: TList; RealICQUser: TRealICQUser; RealICQTeam: TRealICQTeam; begin RootPath := ''; if SelectDirectory('请设置历史聊天记录文件的导出路径', '', RootPath) then begin if RootPath = '' then Exit; RootPath := RootPath + '\历史记录\'; if not DirectoryExists(RootPath) then CreateDir(RootPath); ProcessingForm := TProcessingForm.Create(Self); ProcessingForm.Show; Application.ProcessMessages; Sleep(500); Messages := MainForm.DBHistory.SearchMessage('-1', '','', True, ''); if Messages = nil then Exit; TmpList := TStringList.Create; //群组消息 GroupList := TTeamsAdapter.GetTeams(); if GroupList <> nil then for iLoop := 0 to GroupList.Count - 1 do begin RealICQTeam := GroupList.Objects[iLoop] as TRealICQTeam; if Length(RealICQTeam.TeamCaption) = 0 then FileName := RootPath + '群组：' + RealICQTeam.TeamID + '.txt' else FileName := RootPath + '群组：' + RealICQTeam.TeamCaption + '.txt'; TmpList.Clear; for jLoop := 0 to Messages.Count - 1 do begin MessageSearchResult := Messages[jLoop]; if MessageSearchResult.TeamID = RealICQTeam.TeamID then begin RealICQUser := TUsersService.GetUsersService.GetOrRequestUser(MessageSearchResult.Sender); StrSender := RealICQUser.LoginName; if Pos('-', StrSender) > 0 then StrSender := Copy(StrSender, Pos('-', StrSender) + 1, Length(StrSender)); if (Length(RealICQUser.DisplayName) <> 0) then StrSender := RealICQUser.DisplayName + '(' + StrSender + ')'; StrTmp := DateToStr(MessageSearchResult.SendDateTime) + ' '; StrTmp := StrTmp + TimeToStr(MessageSearchResult.SendDateTime) + ' '; StrTmp := StrTmp + StrSender + #13#10; StrTmp := StrTmp + #13#10 + MessageSearchResult.MessageStr + #13#10; TmpList.Add(StrTmp); end; end; if TmpList.Count > 0 then TmpList.SaveToFile(FileName); end; //手机短信 StrTmp := ''; TmpList.Clear; FileName := RootPath + '手机短信.txt'; for iLoop := 0 to Messages.Count - 1 do begin MessageSearchResult := Messages[iLoop]; if (MessageSearchResult.TeamID = '-2') or (MessageSearchResult.TeamID = '-3') then begin if IsDigit(MessageSearchResult.Sender) then StrSender := MessageSearchResult.Sender else begin RealICQUser := TUsersService.GetUsersService.GetOrRequestUser(MessageSearchResult.Sender); StrSender := RealICQUser.LoginName; if Pos('-', StrSender) > 0 then StrSender := Copy(StrSender, Pos('-', StrSender) + 1, Length(StrSender)); if (Length(RealICQUser.DisplayName) <> 0) then StrSender := RealICQUser.DisplayName + '(' + StrSender + ')'; end; if IsDigit(MessageSearchResult.Receiver) then StrReceiver := MessageSearchResult.Receiver else begin RealICQUser := TUsersService.GetUsersService.GetOrRequestUser(MessageSearchResult.Receiver); StrReceiver := RealICQUser.LoginName; if Pos('-', StrReceiver) > 0 then StrReceiver := Copy(StrReceiver, Pos('-', StrReceiver) + 1, Length(StrReceiver)); if (Length(RealICQUser.DisplayName) <> 0) then StrReceiver := RealICQUser.DisplayName + '(' + StrReceiver + ')'; end; StrTmp := StrTmp + DateToStr(MessageSearchResult.SendDateTime) + ' '; StrTmp := StrTmp + TimeToStr(MessageSearchResult.SendDateTime) + ' '; StrTmp := StrTmp + StrSender + ' -> ' + StrReceiver + #13#10; StrTmp := StrTmp + #13#10 + MessageSearchResult.MessageStr + #13#10; TmpList.Add(StrTmp); end; end; if TmpList.Count > 0 then TmpList.SaveToFile(FileName); //联系人 UserList := MainForm.DBHistory.GetContactors; if UserList <> nil then for iLoop := 0 to UserList.Count - 1 do begin StrLogin := UserList[iLoop]; if (AnsiPos('+', StrLogin) <= 0) and (trim(MainForm.RealICQClient.CenterServerID) <> '') then StrLogin := MainForm.RealICQClient.CenterServerID + '+' + StrLogin; if AnsiSameText(StrLogin, MainForm.RealICQClient.LoginName) then continue; RealICQUser:= TUsersService.GetUsersService.GetOrRequestUser(StrLogin); StrLogin := RealICQUser.LoginName; if Pos('-', StrLogin) > 0 then StrLogin := Copy(StrLogin, Pos('-', StrLogin) + 1, Length(StrLogin)); if (Length(RealICQUser.DisplayName) <> 0) then StrLogin := RealICQUser.DisplayName + '(' + StrLogin + ')'; FileName := RootPath + '联系人：' + StrLogin + '.txt'; TmpList.Clear; for jLoop := 0 to Messages.Count - 1 do begin MessageSearchResult := Messages[jLoop]; if MessageSearchResult.TeamID <> '-1' then continue; if (MessageSearchResult.Sender = UserList[iLoop]) or (MessageSearchResult.Receiver = UserList[iLoop]) then begin if MessageSearchResult.Sender = UserList[iLoop] then begin StrSender := StrLogin; RealICQUser := TUsersService.GetUsersService.GetOrRequestUser(MessageSearchResult.Receiver); StrReceiver := RealICQUser.LoginName; if Pos('-', StrReceiver) > 0 then StrReceiver := Copy(StrReceiver, Pos('-', StrReceiver) + 1, Length(StrReceiver)); if (Length(RealICQUser.DisplayName) <> 0) then StrReceiver := RealICQUser.DisplayName + '(' + StrReceiver + ')'; end else begin StrReceiver := StrLogin; RealICQUser := TUsersService.GetUsersService.GetOrRequestUser(MessageSearchResult.Sender); StrSender := RealICQUser.LoginName; if Pos('-', StrSender) > 0 then StrSender := Copy(StrSender, Pos('-', StrSender) + 1, Length(StrSender)); if (Length(RealICQUser.DisplayName) <> 0) then StrSender := RealICQUser.DisplayName + '(' + StrSender + ')'; end; StrTmp := DateToStr(MessageSearchResult.SendDateTime) + ' '; StrTmp := StrTmp + TimeToStr(MessageSearchResult.SendDateTime) + ' '; StrTmp := StrTmp + StrSender + #13#10; StrTmp := StrTmp + #13#10 + MessageSearchResult.MessageStr + #13#10; TmpList.Add(StrTmp); end; end; if TmpList.Count > 0 then TmpList.SaveToFile(FileName); end; Messages.Free; ProcessingForm.Free; MessageBox(Handle, '所有历史记录导出完成！ ', '提示', MB_OK or MB_ICONINFORMATION); ShellExecute(handle, 'open', PChar('"' + RootPath + '"'), nil, nil, SW_SHOWNORMAL); end; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.btSeeInfoClick(Sender: TObject); var LoginName,Url:String; begin Url:=btSeeInfo.Hint; LoginName := MainForm.RealICQClient.LoginName; if AnsiPos('-',LoginName)>0 then begin LoginName:=Copy(LoginName,AnsiPos('-',LoginName)+1,Length(LoginName)-AnsiPos('-',LoginName)); end; Url := AnsiReplaceText(Url, '[%LoginName%]',LoginName ); Url := AnsiReplaceText(Url, '[%Password%]', MainForm.RealICQClient.Password); Url := AnsiReplaceText(Url, '[%MD5_LoginName%]', MD5En(LoginName)); Url := AnsiReplaceText(Url, '[%MD5_Password%]', MD5En(MainForm.RealICQClient.Password)); Url := AnsiReplaceText(Url, '[%BranchID%]', MainForm.RealICQClient.Me.BranchID); if AnsiSameText(Copy(Url, 1, 5), 'http:') or AnsiSameText(Copy(Url, 1, 6), 'https:') then begin ShellExecute(handle, 'open',PChar(MainForm.GetDefaultBrowser), PChar('"' + String(Url) + '"'),'', SW_SHOWNORMAL) end else ShellExecute(handle, 'open', PChar(MainForm.GetDefaultBrowser),PChar(Format(MainForm.RealICQClient.WebAppBaseURL + LoginURL, [StrToBase64(MainForm.RealICQClient.LoginName), StrToBase64(MD5En(MainForm.RealICQClient.Password)), StrToBase64(ReadMessageURL +Url)])),'',SW_SHOWDEFAULT); end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.cbPageSizeChange(Sender: TObject); begin if tvSenders.Selected.StateIndex = SystemMessageStateIndex then LoadSystemMessages else if tvSenders.Selected.StateIndex = SMSMessageStateIndex then LoadSMSMessages else LoadMessages; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.ShowUsersMessages(ALoginName: String); var Node, NodeUser, NodeGroup: TTreeNode; RealICQUser: TRealICQUser; ACaption: String; begin Node := tvSenders.Items.GetFirstNode; while Node <> nil do begin if AnsiSameStr(ALoginName, '') then begin if Node.StateIndex = SMSMessageStateIndex then begin Node.Selected := True; Exit; end; end else begin if Node.StateIndex = UserStateIndex then begin try RealICQUser := Node.Data; if Assigned(RealICQUser) then begin if RealICQUser.LoginName = ALoginName then begin Node.Selected := True; Exit; end; end; except end; end; end; Node := Node.GetNext; end; RealICQUser:= TUsersService.GetUsersService.GetOrRequestUser(ALoginName); if RealICQUser = nil then Exit; ALoginName := RealICQUser.LoginName; if Pos('-', ALoginName) > 0 then ALoginName := Copy(ALoginName, Pos('-', ALoginName) + 1, Length(ALoginName)); if (Length(RealICQUser.DisplayName) = 0) then ACaption := ALoginName else ACaption := RealICQUser.DisplayName + '<' + ALoginName + '>'; NodeGroup := tvSenders.Items.GetFirstNode.getNextSibling.getNextSibling; //NodeGroup := tvSenders.Items.GetFirstNode; NodeUser := tvSenders.Items.AddChild(NodeGroup, ACaption); NodeUser.Data := RealICQUser; NodeUser.StateIndex := UserStateIndex; NodeUser.ImageIndex := 1; NodeUser.Selected := True; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.ShowTeamsMessages(ATeamID: String); var Node: TTreeNode; RealICQTeam: TRealICQTeam; begin Node := tvSenders.Items.GetFirstNode; while Node <> nil do begin if Node.StateIndex = TeamStateIndex then begin try RealICQTeam := Node.Data; if Assigned(RealICQTeam) then begin if RealICQTeam.TeamID = ATeamID then begin Node.Selected := True; Exit; end; end; except end; end; Node := Node.GetNext; end; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.LoadTreeViewItems; var iLoop, jLoop, iIndex: Integer; LoginName, ALoginName, ACaption, GroupName: String; ATeams, AUsers, GroupMembers, AlreadyAddedUsers, OtherContactors: TStringList; BranchNodes: TList; RealICQUser: TRealICQUser; RealICQTeam: TRealICQTeam; NodeGroup, NodeUser: TTreeNode; Branch, TmpBranch: TRealICQBranch; BranchInfo: TRealICQBranchInfo; Employee: TRealICQEmployee; ATreeView: TRealICQContacterTreeView; procedure AddGroupUsers(AGroupName: String; GroupList: TStringList); var kLoop: Integer; begin try NodeGroup := tvSenders.Items.AddChild(nil, AGroupName); NodeGroup.StateIndex := 0; NodeGroup.ImageIndex := 4; if (GroupList = nil) then Exit; for kLoop := 0 to GroupList.Count - 1 do begin LoginName := GroupList[kLoop]; if AGroupName='其他联系人' then begin if (AnsiPos('+',LoginName)<=0) and (trim(MainForm.RealICQClient.CenterServerID)<>'') then LoginName := MainForm.RealICQClient.CenterServerID + '+' + LoginName; end; if AnsiSameText(LoginName, MainForm.RealICQClient.LoginName) then continue; if AlreadyAddedUsers.IndexOf(LoginName) >= 0 then continue; //RealICQUser := GroupList.Objects[kLoop] as TRealICQUser; RealICQUser:= TUsersService.GetUsersService.GetOrRequestUser(LoginName); ALoginName := RealICQUser.LoginName; if Pos('-', ALoginName) > 0 then ALoginName := Copy(ALoginName, Pos('-', ALoginName) + 1, Length(ALoginName)); if (Length(RealICQUser.DisplayName) = 0) then ACaption := ALoginName else ACaption := RealICQUser.DisplayName + '<' + ALoginName + '>'; NodeUser := tvSenders.Items.AddChild(NodeGroup, ACaption); NodeUser.Data := RealICQUser; NodeUser.StateIndex := UserStateIndex; NodeUser.ImageIndex := 1; AlreadyAddedUsers.Add(LoginName); cbSearchRange.Items.Add(ACaption); end; finally FreeAndNil(GroupList); end; end; begin AlreadyAddedUsers := TStringList.Create; tvSenders.Items.Clear; cbSearchRange.Items.Clear; cbSearchRange.Items.Add('全部记录'); if MainForm.ShowGroup and (MainForm.RealICQClient.WorkingMode = wmPublic) then begin for iLoop := MainForm.Groups.Count - 1 downto 0 do begin GroupName := MainForm.Groups[iLoop]; NodeGroup := tvSenders.Items.AddChildFirst(nil, GroupName); NodeGroup.StateIndex := 0; NodeGroup.ImageIndex := 4; GroupMembers := MainForm.Groups.Objects[iLoop] as TStringList; for jLoop := 0 to GroupMembers.Count - 1 do begin LoginName := GroupMembers[jLoop]; RealICQUser:= TUsersService.GetUsersService.GetUser(LoginName); if RealICQUser <> nil then begin ALoginName := RealICQUser.LoginName; if Pos('-', ALoginName) > 0 then ALoginName := Copy(ALoginName, Pos('-', ALoginName) + 1, Length(ALoginName)); if (Length(RealICQUser.DisplayName) = 0) then ACaption := ALoginName else ACaption := RealICQUser.DisplayName + '<' + ALoginName + '>'; NodeUser := tvSenders.Items.AddChild(NodeGroup, ACaption); NodeUser.Data := RealICQUser; NodeUser.StateIndex := UserStateIndex; NodeUser.ImageIndex := 1; AlreadyAddedUsers.Add(LoginName); cbSearchRange.Items.Add(ACaption); end; end; end; end; //if MainForm.RealICQClient.WorkingMode = wmPublic then //begin //好友/联系人列表 //GroupName := LVFriends; //AddGroupUsers(GroupName, MainForm.RealICQClient.Friends); //NodeGroup.MoveTo(NodeGroup.Parent, naAddChildFirst); //陌生人列表 //AddGroupUsers(LVStrangers, MainForm.RealICQClient.Strangers); //黑名单列表 //AddGroupUsers(LVBlacklists, MainForm.RealICQClient.Blacklists); //end //else //begin try BranchNodes := TList.Create; {$region '添加部门'} for iLoop := 0 to MainForm.RealICQClient.Branchs.Count - 1 do begin BranchInfo := MainForm.RealICQClient.Branchs.Objects[iLoop] as TRealICQBranchInfo; Branch := TRealICQBranch.Create(BranchInfo.BranchName); Branch.BranchID := BranchInfo.ID; Branch.ParentID := BranchInfo.ParentID; Branch.Node := tvSenders.Items.AddChildObject(nil, Branch.BranchName, Branch); Branch.Node.StateIndex := 0; Branch.Node.ImageIndex := 4; for jLoop := 0 to BranchNodes.Count - 1 do begin NodeGroup := BranchNodes[jLoop]; TmpBranch := TRealICQBranch(NodeGroup.Data); if AnsiSameText(Branch.ParentID, TmpBranch.BranchID) then begin Branch.Node.MoveTo(TmpBranch.Node, naAddChild); TmpBranch.Node.Expanded := False; Break; end; end; BranchNodes.Add(Branch.Node); end; for iLoop := 0 to tvSenders.Items.Count - 1 do begin Branch := TRealICQBranch(tvSenders.Items.Item[iLoop].Data); for jLoop := 0 to tvSenders.Items.Count - 1 do {添加至父部门} begin if iLoop = jLoop then continue; TmpBranch := TRealICQBranch(tvSenders.Items.Item[jLoop].Data); if AnsiSameText(Branch.ParentID, TmpBranch.BranchID) then begin if Branch.Node.Parent = TmpBranch.Node then continue; Branch.Node.MoveTo(TmpBranch.Node, naAddChild); TmpBranch.Node.Expanded := False; Break; end; end; end; {$endregion} {$region '添加用户'} AUsers := TUsersService.GetUsersService.GetWorkmatesAndFriends; for iLoop := AUsers.Count - 1 downto 0 do begin RealICQUser := AUsers.Objects[iLoop] as TRealICQUser; ALoginName := RealICQUser.LoginName; if Pos('-', ALoginName) > 0 then ALoginName := Copy(ALoginName, Pos('-', ALoginName) + 1, Length(ALoginName)); if (Length(RealICQUser.DisplayName) = 0) then ACaption := ALoginName else ACaption := RealICQUser.DisplayName + '<' + ALoginName + '>'; cbSearchRange.Items.Add(ACaption); Employee := TRealICQEmployee.Create(RealICQUser.LoginName); Employee.BranchID := RealICQUser.BranchID; for jLoop := 0 to BranchNodes.Count - 1 do begin NodeGroup := BranchNodes[jLoop]; if NodeGroup.StateIndex <> 0 then continue; TmpBranch := TRealICQBranch(NodeGroup.Data); if AnsiSameText(Employee.BranchID, TmpBranch.BranchID) then begin Employee.Node := tvSenders.Items.AddChildObjectFirst(TmpBranch.Node, ACaption, Employee); Employee.Node.StateIndex := UserStateIndex; Employee.Node.ImageIndex := 1; Employee.Node.Data:=RealICQUser; TmpBranch.Node.Expanded := False; AlreadyAddedUsers.Add(Employee.LoginName); Break; end; end; end; {$endregion} finally FreeAndNil(BranchNodes); if AUsers <> nil then FreeAndNil(AUsers); end; //end; GroupName := LVFriends; AddGroupUsers(GroupName, TFriendsService.GetService.GetFriends); NodeGroup.MoveTo(NodeGroup.Parent, naAddChildFirst); GroupName := '其他联系人'; OtherContactors := MainForm.DBHistory.GetContactors; AddGroupUsers(GroupName, OtherContactors); //添加群组列表 NodeGroup := tvSenders.Items.AddChild(nil, LVTeams); NodeGroup.StateIndex := 0; NodeGroup.ImageIndex := 4; ATeams := TTeamsAdapter.GetTeams(); if ATeams <> nil then for iLoop := 0 to ATeams.Count - 1 do begin RealICQTeam := ATeams.Objects[iLoop] as TRealICQTeam; if Length(RealICQTeam.TeamCaption) = 0 then ACaption := RealICQTeam.TeamID else ACaption := RealICQTeam.TeamCaption + '<群号码:' + RealICQTeam.TeamID + '>'; NodeUser := tvSenders.Items.AddChild(NodeGroup, ACaption); NodeUser.Data := RealICQTeam; NodeUser.StateIndex := TeamStateIndex; NodeUser.ImageIndex := 5; cbSearchRange.Items.Add(ACaption); end; //添加手机短消息结节 NodeGroup := tvSenders.Items.AddChild(nil, '手机短信'); NodeGroup.StateIndex := SMSMessageStateIndex; NodeGroup.ImageIndex := 8; //添加系统消息结节 NodeGroup := tvSenders.Items.AddChild(nil, LVSystemMessage); NodeGroup.StateIndex := SystemMessageStateIndex; NodeGroup.ImageIndex := 6; //添加查找结果结节 NodeGroup := tvSenders.Items.AddChild(nil, '查找结果'); NodeGroup.StateIndex := SearchResultStateIndex; NodeGroup.ImageIndex := 7; AlreadyAddedUsers.Free; cbSearchRange.ItemIndex := 0; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.SpeedButton1Click(Sender: TObject); var DBFile: String; begin if Length(Trim(MainForm.RealICQClient.DBHistoryFileName)) > 0 then begin if MessageBox(Handle, PChar(Format('确定要替换服务器上%s的消息记录吗?', [DateTimeToStr(MainForm.RealICQClient.DBHistoryFileUploadDateTime)])), '提示', MB_OKCANCEL or MB_ICONQUESTION) <> ID_OK then Exit; end; DBFile := MainForm.DBHistory.DBFileName; try try MainForm.DBHistory.CloseDBConntion; FFileTransmitter := TFileTransmitter.Create(MainForm.RealICQClient.TCPClient, tdSender, DBFile, 2, MainForm.RealICQClient.LoginName, 0, 0); FFileTransmitter.OnTransmitting := FileTransmitterCalculatedSpeed; FFileTransmitter.OnTransmitOK := FileTransmitterCompleted; FFileTransmitter.SendFileRequest; SpeedButton1.Enabled := False; except On E: Exception do MessageBox(Handle, PChar('备份消息记录时出错：' + E.Message), '提示', MB_OK); end; finally // MainForm.DBHistory.DBFileName := DBFile; end; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.SpeedButton2Click(Sender: TObject); begin if Length(Trim(MainForm.RealICQClient.DBHistoryFileName)) = 0 then begin MessageBox(Handle, '没有备份记录！', '提示', MB_OK); Exit; end; if MessageBox(Handle, PChar(Format('确定要将 %s 的消息记录恢复至本地吗?', [DateTimeToStr(MainForm.RealICQClient.DBHistoryFileUploadDateTime)])), '提示', MB_OKCANCEL or MB_ICONQUESTION) <> ID_OK then Exit; FDownFile := TDownFile.Create; FDownFile.OnComplete := DownFileComplete; FDownFile.OnProgress := DownFileProgress; FDBFile := MainForm.DBHistory.DBFileName + '.TEMP'; FDownFile.ThreadDownFile(MainForm.RealICQClient.DBHistoryFileName, FDBFile); SpeedButton2.Enabled := False; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.FileTransmitterCalculatedSpeed(Sender: TObject; ATransmittedSize: Int64); var Completed: Integer; begin Completed := ATransmittedSize*100 div FFileTransmitter.StreamLength; SpeedButton1.Caption := IntToStr(Completed)+'%'; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.FileTransmitterCompleted(Sender: TObject); begin SpeedButton1.Enabled := True; SpeedButton1.Caption := '备份'; MessageBox(Handle, PChar('消息记录已成功备份至服务器'), '提示', MB_OK or MB_ICONINFORMATION); MainForm.DBHistory.OpenDBConntion; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.DownFileProgress(ulProgress, ulProgressMax, ulStatusCode: integer; szStatusText: String); var Completed: Integer; begin if ulProgressMax = 0 then Exit; Completed := ulProgress*100 div ulProgressMax; SpeedButton2.Caption := IntToStr(Completed)+'%'; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.DownFileComplete(Source_file, Dest_file:String; blStatus:boolean; ErrMessage:String); begin SpeedButton2.Caption := '恢复'; SpeedButton2.Enabled := True; if blStatus then begin try ProcessingForm := TProcessingForm.Create(Self); ProcessingForm.pnlClient.Caption := '正在恢复记录，请稍候...'; ProcessingForm.Show; Application.ProcessMessages; Sleep(400); try MainForm.DBHistory.RestoreMessageHistory(FDBFile); finally ProcessingForm.Free; end; MessageBox(Handle, '恢复消息记录成功！', '提示', MB_ICONINFORMATION); except MessageBox(Handle, PChar('恢复消息记录失败: ' + ErrMessage), '错误', MB_ICONERROR); end; end else begin MessageBox(Handle, PChar('恢复消息记录失败: ' + ErrMessage), '错误', MB_ICONERROR); end; btRefresh.Click; //tvSendersChange(tvSenders, tvSenders.Selected); end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.lvContentsResize(Sender: TObject); begin lvContents.Columns.Items[3].Width := lvContents.Width - 308; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.miDelMessageHistoryClick(Sender: TObject); var Node: TTreeNode; RealICQUser: TRealICQUser; RealICQTeam: TRealICQTeam; begin Node := tvSenders.Selected; if Node = nil then Exit; if MessageBox(Handle, '确定要删除这些消息记录吗？', '确认删除', MB_ICONQUESTION or MB_OKCANCEL) <> ID_OK then begin Exit; end; if Node.StateIndex = UserStateIndex then begin RealICQUser := Node.Data; MainForm.DBHistory.DelMessageByLoginName(RealICQUser.LoginName); end else if Node.StateIndex = TeamStateIndex then begin RealICQTeam := Node.Data; MainForm.DBHistory.DelMessageByTeamID(RealICQTeam.TeamID); end else if Node.StateIndex = SystemMessageStateIndex then begin MainForm.DBHistory.DelAllSystemMessage; end; if Node.Parent = tvSenders.Items.GetFirstNode.getNextSibling.getNextSibling then begin FreeAndNil(Node); end; tvSendersChange(tvSenders, Node); end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.ppListViewPopup(Sender: TObject); begin MenuItem1.Enabled := btDel.Enabled; end; procedure TMessagesManagerForm.ppTreeNodePopup(Sender: TObject); begin miDelMessageHistory.Visible := tvSenders.Selected <> nil; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.lvContentsChange(Sender: TObject; Item: TListItem; Change: TItemChange); var MessageSearchResult: TMessageSearchResult; SystemMessageSearchResult: TSystemMessageSearchResult; AMessageStr,Content: String; Password,AReceiver:String; TempMessage:TMessageSearchResult; hwnd:THandle; UserName:String; begin if lvContents.SelCount > 0 then begin if not btDel.Enabled then begin btDel.Enabled := True; end; end else begin if btDel.Enabled then begin btDel.Enabled := False; end; end; if Item = nil then Exit; AMessageStr := ''; lblDate.Caption := '日期: ' + Item.SubItems[0]; lblTime.Caption := '时间: ' + Item.SubItems[1]; lblSender.Caption := '发信人: ' + Item.Caption; btSeeInfo.Visible:=False; ClearHTML(WebBrowser); if (Item.StateIndex = UserStateIndex) or (Item.StateIndex = TeamStateIndex) or (Item.StateIndex = SMSMessageStateIndex) then begin MessageSearchResult := Item.Data; if MessageSearchResult.IsEncryMessage then begin hWnd:=FindWindow(nil,pchar(trim('输入密码'))); if hWnd>0 then Exit; Password:=(ShowMyInputBox('输入密码','密码','', 50)); if Password<>MainForm.RealICQClient.Password then begin if Password<>'' then Dialogs.ShowMessage('密码错误'); Exit; end; TempMessage:=MainForm.DBHistory.GetMessageByMessageID(IntToStr(MessageSearchResult.ID)); if (MainForm.RealICQClient.CenterServerID<>'') and (AnsiPos('+',TempMessage.Sender)<=0) then AReceiver:=MainForm.RealICQClient.CenterServerID+'+' + TempMessage.Sender; if (not TempMessage.IsRead) and (MainForm.RealICQClient.LoginName<>AReceiver) then //发送已经查看私密消息确认信息给发送者 begin UserName:=MainForm.RealICQClient.Me.DisplayName; if Trim(UserName)='' then UserName:=MainForm.RealICQClient.Me.LoginName; Content:='LXC01'+#13+#10+'LXUMC'+#13+#10+'0'+ #13+#10+'您于［'+DateTimeToStr(TempMessage.SendDateTime) +'］发送给'+UserName+'的签收消息对方已经阅读！'; MainForm.RealICQClient.SendCustomMessage(MainForm.RealICQClient.LoginName,AReceiver,Content); end; end; AMessageStr := FilterHTMLCode(MessageSearchResult.MessageStr, MainForm.AllowURL); if MessageSearchResult.TeamID <> '-5' then GetFaces2(AMessageStr, True); AddFontStyle(AMessageStr, MessageSearchResult.Font); end; if (Item.StateIndex = SystemMessageStateIndex) then begin SystemMessageSearchResult := Item.Data; if SystemMessageSearchResult.MessageType = mtBroadcast then AMessageStr := SystemMessageSearchResult.Content else AMessageStr := SystemMessageSearchResult.Title; if trim(SystemMessageSearchResult.Url)<>'' then begin btSeeInfo.Hint:=SystemMessageSearchResult.Url; btSeeInfo.Visible:=True; end; end; InsertHTML(WebBrowser, AMessageStr); end; procedure TMessagesManagerForm.lvContentsClick(Sender: TObject); begin if lvContents.Selected<>nil then self.lvContentsChange(Sender,lvContents.Selected,ctText); end; procedure TMessagesManagerForm.lvContentsColumnClick(Sender: TObject; Column: TListColumn); begin // end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.lvContentsDblClick(Sender: TObject); var Item: TListItem; SystemMessageSearchResult: TSystemMessageSearchResult; begin Item := lvContents.Selected; if Item = nil then Exit; if (Item.StateIndex = SystemMessageStateIndex) then begin SystemMessageSearchResult := Item.Data; OpenSystemMessageForm(IntToStr(SystemMessageSearchResult.MessageID), SystemMessageSearchResult.MessageType, SystemMessageSearchResult.PositionType, SystemMessageSearchResult.Left, SystemMessageSearchResult.Top, SystemMessageSearchResult.Width, SystemMessageSearchResult.Height, SystemMessageSearchResult.Title, SystemMessageSearchResult.Content, SystemMessageSearchResult.URL, SystemMessageSearchResult.AutoCloseTime); end; end; procedure TMessagesManagerForm.lvContentsMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.btDelClick(Sender: TObject); var iLoop: Integer; ListItem: TListItem; MessageSearchResult: TMessageSearchResult; SystemMessageSearchResult: TSystemMessageSearchResult; begin {if tvSenders.Focused then begin miDelMessageHistory.Click; Exit; end;} if MessageBox(Handle, '确定要删除选中的消息记录吗？', '确认删除', MB_ICONQUESTION or MB_OKCANCEL) <> ID_OK then begin Exit; end; for iLoop := lvContents.Items.Count - 1 downto 0 do begin ListItem := lvContents.Items.Item[iLoop]; if ListItem.Selected then begin if ListItem.StateIndex = SystemMessageStateIndex then begin SystemMessageSearchResult := ListItem.Data; MainForm.DBHistory.DelSystemMessage(SystemMessageSearchResult.ID); FreeAndNil(SystemMessageSearchResult); end else begin MessageSearchResult := ListItem.Data; MainForm.DBHistory.DelMessage(MessageSearchResult.ID); FreeAndNil(MessageSearchResult); end; lvContents.Items.Delete(iLoop); //ClearContents; end; end; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.btLastClick(Sender: TObject); begin FPageIndex := 1000000; if tvSenders.Selected.StateIndex = SystemMessageStateIndex then LoadSystemMessages else if tvSenders.Selected.StateIndex = SMSMessageStateIndex then LoadSMSMessages else LoadMessages; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.btNextClick(Sender: TObject); begin Inc(FPageIndex); if tvSenders.Selected.StateIndex = SystemMessageStateIndex then LoadSystemMessages else if tvSenders.Selected.StateIndex = SMSMessageStateIndex then LoadSMSMessages else LoadMessages; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.btFirstClick(Sender: TObject); begin FPageIndex := 1; if tvSenders.Selected.StateIndex = SystemMessageStateIndex then LoadSystemMessages else if tvSenders.Selected.StateIndex = SMSMessageStateIndex then LoadSMSMessages else LoadMessages; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.btPrevClick(Sender: TObject); begin Dec(FPageIndex); if tvSenders.Selected.StateIndex = SystemMessageStateIndex then LoadSystemMessages else if tvSenders.Selected.StateIndex = SMSMessageStateIndex then LoadSMSMessages else LoadMessages; end; procedure TMessagesManagerForm.btRefreshClick(Sender: TObject); begin Self.ClearContents; ClearHTML(WebBrowser); LoadTreeViewItems; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.ClearContents; var iLoop: Integer; DataObj: TObject; begin for iLoop := 0 to lvContents.Items.Count - 1 do begin DataObj := lvContents.Items.Item[iLoop].Data; FreeAndNil(DataObj); end; lvContents.Items.Clear; lblDate.Caption := '日期:'; lblTime.Caption := '时间:'; lblSender.Caption := '发信人:'; ClearHTML(WebBrowser); end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.ShowSystemMessages(Messages: TList); var iLoop: Integer; SystemMessageSearchResult: TSystemMessageSearchResult; AMessageStr: String; begin SetPageSetsState; lvContents.Items.BeginUpdate; try ClearContents; for iLoop := 0 to Messages.Count - 1 do begin SystemMessageSearchResult := Messages[iLoop]; with lvContents.Items.Add do begin StateIndex := tvSenders.Selected.StateIndex; ImageIndex := 6; Caption := '系统管理员'; SubItems.Add(DateToStr(SystemMessageSearchResult.SendDateTime)); SubItems.Add(TimeToStr(SystemMessageSearchResult.SendDateTime)); if SystemMessageSearchResult.MessageType = mtBroadcast then AMessageStr := '系统广播：' else AMessageStr := '系统广告：'; AMessageStr := AMessageStr + SystemMessageSearchResult.Title; SubItems.Add(AMessageStr); Data := SystemMessageSearchResult; end; end; finally lvContents.Items.EndUpdate; SendMessage(lvContents.Handle, WM_VSCROLL, SB_BOTTOM, 0); //发送到底消息 Messages.Free; end; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.SetPageSetsState; begin lblPages.Caption := Format('%d 条记录，第 %d 页、共 %d 页', [FRecordCount, FPageIndex, FPageCount]); if FPageIndex < FPageCount then btNext.Enabled := True else btNext.Enabled := False; if FPageIndex > 1 then btPrev.Enabled := True else btPrev.Enabled := False; btFirst.Enabled := btPrev.Enabled; btLast.Enabled := btNext.Enabled; pnlPageSet.Visible := True; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.ShowMessages(Messages: TList); var iLoop: Integer; RealICQUser: TRealICQUser; MessageSearchResult: TMessageSearchResult; AMessageStr, ReceiverName: String; ALoginName: String; begin SetPageSetsState; lvContents.OnChange := nil; lvContents.Items.BeginUpdate; try ClearContents; for iLoop := 0 to Messages.Count - 1 do begin MessageSearchResult := Messages[iLoop]; with lvContents.Items.Add do begin StateIndex := tvSenders.Selected.StateIndex; if (StateIndex = UserStateIndex) or (StateIndex = SMSMessageStateIndex) then begin //Dialogs.ShowMessage(MessageSearchResult.TeamID); if ((MessageSearchResult.TeamID = '-2') or (MessageSearchResult.TeamID = '-3')) then begin ImageIndex := 8; end else begin ImageIndex := 1; end; end else ImageIndex := 5; RealICQUser:= TUsersService.GetUsersService.GetOrRequestUser(MessageSearchResult.Sender); ALoginName := RealICQUser.LoginName; if Pos('-', ALoginName) > 0 then ALoginName := Copy(ALoginName, Pos('-', ALoginName) + 1, Length(ALoginName)); if (Length(RealICQUser.DisplayName) = 0) then Caption := ALoginName else Caption := RealICQUser.DisplayName + '<' + ALoginName + '>'; if MessageSearchResult.TeamID <= '-2' then begin RealICQUser:= TUsersService.GetUsersService.GetOrRequestUser(MessageSearchResult.Receiver); ALoginName := RealICQUser.LoginName; if Pos('-', ALoginName) > 0 then ALoginName := Copy(ALoginName, Pos('-', ALoginName) + 1, Length(ALoginName)); if (Length(RealICQUser.DisplayName) = 0) then ReceiverName := RealICQUser.LoginName else ReceiverName := RealICQUser.DisplayName + '<' + RealICQUser.LoginName + '>'; Caption := Caption + ' -> ' + ReceiverName; end; SubItems.Add(DateToStr(MessageSearchResult.SendDateTime)); SubItems.Add(TimeToStr(MessageSearchResult.SendDateTime)); AMessageStr := MessageSearchResult.MessageStr; if MessageSearchResult.IsEncryMessage then begin if MessageSearchResult.Sender=MainForm.RealICQClient.LoginName then AMessageStr:='您发送了一条签收消息' else AMessageStr:='您收到了一条签收消息'; end else AMessageStr := MessageSearchResult.MessageStr; GetFaces2(AMessageStr, False); SubItems.Add(AMessageStr); Data := MessageSearchResult; end; end; finally lvContents.Items.EndUpdate; // lvContents.OnChange := lvContentsChange; SendMessage(lvContents.Handle, WM_VSCROLL, SB_BOTTOM, 0); //发送到底消息 Messages.Free; end; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.LoadMessages; var DBHistorySearchResult: TDBHistorySearchResult; begin try DBHistorySearchResult := MainForm.DBHistory.GetMessage(FTeamID, FSender, FReceiver, StrToDate('1900-01-01'), 0, FPageIndex, StrToInt(cbPageSize.Text)); except DBHistorySearchResult := MainForm.DBHistory.GetMessage(FTeamID, FSender, FReceiver, StrToDate('1900/01/01'), 0, FPageIndex, StrToInt(cbPageSize.Text)); end; try FRecordCount := DBHistorySearchResult.RecordCount; FPageCount := DBHistorySearchResult.PageCount; FPageIndex := DBHistorySearchResult.PageIndex; ShowMessages(DBHistorySearchResult.Messages); finally DBHistorySearchResult.Free; end; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.LoadSystemMessages; var DBHistorySearchResult: TDBHistorySearchResult; begin try DBHistorySearchResult := MainForm.DBHistory.GetSystemMessage(StrToDate('1900-01-01'), FPageIndex, StrToInt(cbPageSize.Text)); except DBHistorySearchResult := MainForm.DBHistory.GetSystemMessage(StrToDate('1900/01/01'), FPageIndex, StrToInt(cbPageSize.Text)); end; try FRecordCount := DBHistorySearchResult.RecordCount; FPageCount := DBHistorySearchResult.PageCount; FPageIndex := DBHistorySearchResult.PageIndex; ShowSystemMessages(DBHistorySearchResult.Messages); finally DBHistorySearchResult.Free; end; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.LoadSMSMessages; var DBHistorySearchResult: TDBHistorySearchResult; begin try DBHistorySearchResult := MainForm.DBHistory.GetMessage('-3', '', '', StrToDate('1900-01-01'), 0, FPageIndex, StrToInt(cbPageSize.Text)); except DBHistorySearchResult := MainForm.DBHistory.GetMessage('-3', '', '', StrToDate('1900/01/01'), 0, FPageIndex, StrToInt(cbPageSize.Text)); end; try FRecordCount := DBHistorySearchResult.RecordCount; FPageCount := DBHistorySearchResult.PageCount; FPageIndex := DBHistorySearchResult.PageIndex; ShowMessages(DBHistorySearchResult.Messages); finally DBHistorySearchResult.Free; end; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.tvSendersChange(Sender: TObject; Node: TTreeNode); var RealICQUser: TRealICQUser; RealICQTeam: TRealICQTeam; begin btSeeInfo.Visible:=False; lvContents.Items.BeginUpdate; try ClearContents; if Node = nil then Exit; if Node.StateIndex = UserStateIndex then begin {$region '选择了某个用户'} RealICQUser := Node.Data; FTeamID := '-2'; FSender := RealICQUser.LoginName; FReceiver := MainForm.RealICQClient.LoginName; FPageCount := 0; FPageIndex := 1000000; LoadMessages; {$endregion} cbSearchRange.ItemIndex := cbSearchRange.Items.IndexOf(Node.Text); Exit; end; if Node.StateIndex = TeamStateIndex then begin {$region '选择了某个群组'} RealICQTeam := Node.Data; FTeamID := RealICQTeam.TeamID; FSender := ''; FReceiver := ''; FPageCount := 0; FPageIndex := 1000000; LoadMessages; {$endregion} cbSearchRange.ItemIndex := cbSearchRange.Items.IndexOf(Node.Text); Exit; end; if Node.StateIndex = SystemMessageStateIndex then begin {$region '选择了系统消息节点'} FPageCount := 0; FPageIndex := 1000000; LoadSystemMessages; Exit; {$endregion} end; if Node.StateIndex = SMSMessageStateIndex then begin {$region '选择了手机短消息节点'} FPageCount := 0; FPageIndex := 1000000; LoadSMSMessages; Exit; {$endregion} end; cbSearchRange.ItemIndex := 0; pnlPageSet.Visible := False; finally lvContents.Items.EndUpdate; end; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.tvSendersCustomDrawItem(Sender: TCustomTreeView; Node: TTreeNode; State: TCustomDrawState; var DefaultDraw: Boolean); begin DefaultDraw := True; if Node.StateIndex = 0 then begin if Node.Expanded then Node.ImageIndex := 3 else Node.ImageIndex := 4; end; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.tvSendersGetSelectedIndex(Sender: TObject; Node: TTreeNode); begin Node.SelectedIndex := Node.ImageIndex; end; procedure TMessagesManagerForm.tvSendersMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var Node: TTreeNode; P: TPoint; begin Node := tvSenders.GetNodeAt(X, Y); if Node = nil then Exit; Node.Selected := True; if Button <> mbRight then Exit; if (Node.StateIndex = UserStateIndex) or (Node.StateIndex = TeamStateIndex) or (Node.StateIndex = SystemMessageStateIndex) then begin P.X := X; P.Y := Y; P := tvSenders.ClientToScreen(P); ppTreeNode.Popup(P.X, P.Y); end; end; {设置WebBrowser的样式} //------------------------------------------------------------------------------ procedure TMessagesManagerForm.SetDOMStyle(Doc:IHTMLDocument2); begin Doc.body.style.cssText := 'word-break: break-all;'; Doc.body.style.border := '0px solid'; Doc.body.style.fontFamily := '宋体'; Doc.body.style.fontSize := '9pt'; Doc.body.style.margin := '2pt'; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.WebBrowserBeforeNavigate2(ASender: TObject; const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool); const BaseURL = 'about:blank'; BaseURL1 = 'about:'; var NewUrl, BaseID: string; function GetBaseIDFromUrl(SrcUrl:String):String; begin result := Copy(SrcUrl, AnsiPos('_',SrcUrl) + 1, Length(SrcUrl)); end; begin if (Pos(FBaseURL, String(URL)) < 1) and (Pos('about:blank', String(URL)) < 1) then Exit; URL := Trim(AnsiReplaceText(String(URL), FBaseURL, '')); if TFileTransmitAdapter.HandleMessage(Self, URL, Cancel) then Exit; NewUrl := Trim(AnsiReplaceText(String(URL), BaseURL, '')); NewUrl := Trim(AnsiReplaceText(String(NewUrl), BaseURL1, '')); {$region '打开文件'} if AnsiSameText(Copy(NewUrl, 1, 7) , 'File://') then begin Cancel := True; BaseID := AnsiReplaceStr(GetBaseIDFromUrl(NewUrl),'%20',' '); if AnsiSameText(ExtractFileExt(BaseID), '.EXE') or AnsiSameText(ExtractFileExt(BaseID), '.COM') then begin if MessageBox(Handle, '直接打开可执行文件可能会有感染病毒的风险，确实要打开此文件吗？', '警告', MB_ICONWARNING or MB_OKCANCEL) <> ID_OK then Exit; end; if FileExists(BaseID) then ShellExecute(handle, 'open', PChar('"' + BaseID + '"'), nil, nil, SW_SHOWNORMAL) else Dialogs.ShowMessage('本地电脑已经不存在此文件。'); Exit; end; {$endregion} {$region '打开所在文件夹'} if AnsiSameText(Copy(NewUrl, 1, 7) , 'Path://') then begin Cancel := True; BaseID := AnsiReplaceStr(GetBaseIDFromUrl(NewUrl),'%20',' '); WinExec(PChar('explorer /select,"' + BaseID + '"'), SW_SHOWNORMAL); Exit; end; {$endregion} end; procedure TMessagesManagerForm.WebBrowserDocumentComplete(ASender: TObject; const pDisp: IDispatch; var URL: OleVariant); begin try SetDomStyle(WebBrowser.Document as IHtmlDocument2); except end; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.FormClose(Sender: TObject; var Action: TCloseAction); begin Action := caFree; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean); begin lvContents.OnChange := nil; CanClose := True; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.FormCreate(Sender: TObject); begin SkinName := AnsiReplaceText(MainForm.SkinName, 'MainForm', ''); ChangeUIColor(MainForm.UIMainColor); FFileTransmitter := nil; lvContents.DoubleBuffered := True; WebBrowser.Navigate(ExtractFilePath(paramstr(0)) + 'html\chat.html'); FBaseURL := ExtractFilePath(paramstr(0)) + 'html\'; AddUserStatePictureToImageList(ImgLstNodeImage); LoadTreeViewItems; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.FormDestroy(Sender: TObject); begin MessagesManagerForm := nil; end; //------------------------------------------------------------------------------ procedure TMessagesManagerForm.CreateParams(var Params: TCreateParams); begin inherited; with Params do begin Params.WndParent := 0; end; end; end.