source: cprs/trunk/CPRS-Chart/dShared.pas@ 1679

Last change on this file since 1679 was 1679, checked in by healthsevak, 9 years ago

Updating the working copy to CPRS version 28
File size: 25.4 KB
Line 
1unit dShared;
2interface
3
4uses
5 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
6 ComCtrls, ImgList, uTemplates, ORFn, ORNet, ExtCtrls, ORCtrls, Richedit,
7 VA508ImageListLabeler;
8
9type
10 TdmodShared = class(TDataModule)
11 imgTemplates: TImageList;
12 imgReminders: TImageList;
13 imgNotes: TImageList;
14 imgImages: TImageList;
15 imgReminders2: TImageList;
16 imgConsults: TImageList;
17 imgSurgery: TImageList;
18 imgLblReminders: TVA508ImageListLabeler;
19 imgLblHealthFactorLabels: TVA508ImageListLabeler;
20 imgLblNotes: TVA508ImageListLabeler;
21 imgLblImages: TVA508ImageListLabeler;
22 imgLblConsults: TVA508ImageListLabeler;
23 imgLblSurgery: TVA508ImageListLabeler;
24 imgLblReminders2: TVA508ImageListLabeler;
25 procedure dmodSharedCreate(Sender: TObject);
26 procedure dmodSharedDestroy(Sender: TObject);
27 private
28 FTIUObjects: TStringList;
29 FInEditor: boolean;
30 FOnTemplateLock: TNotifyEvent;
31 FTagIndex: longint;
32 FDrawerTrees: TList;
33 FRefreshObject: boolean;
34 protected
35 procedure EncounterLocationChanged(Sender: TObject);
36 public
37 function ImgIdx(Node: TTreeNode): integer;
38 procedure AddTemplateNode(Tree: TTreeView; var EmptyCount: integer;
39 const tmpl: TTemplate; AllowInactive: boolean = FALSE;
40 const Owner: TTreeNode = nil);
41 function ExpandNode(Tree: TTreeView; Node: TTreeNode;
42 var EmptyCount: integer; AllowInactive: boolean = FALSE): boolean;
43 procedure Resync(SyncNode: TTreeNode; AllowInactive: boolean;
44 var EmptyCount: integer);
45 procedure AddDrawerTree(DrawerForm: TForm);
46 procedure RemoveDrawerTree(DrawerForm: TForm);
47 procedure Reload;
48 procedure LoadTIUObjects;
49 function BoilerplateOK(const Txt, CRDelim: string; ObjList: TStringList;
50 var Err: TStringList): boolean;
51 function TemplateOK(tmpl: TTemplate; Msg: string = ''): boolean;
52 function NeedsCollapsing(Tree: TTreeView): boolean;
53 procedure SelectNode(Tree: TORTreeView; GotoNodeID: string; var EmptyCount: integer);
54 procedure ExpandTree(Tree: TORTreeView; ExpandString: string; var EmptyCount: integer;
55 AllowInactive: boolean = FALSE);
56 function InDialog(Node: TTreeNode): boolean;
57 property InEditor: boolean read FInEditor write FInEditor;
58 property OnTemplateLock: TNotifyEvent read FOnTemplateLock write FOnTemplateLock;
59 property TIUObjects: TStringList read FTIUObjects;
60 property RefreshObject: boolean read FRefreshObject write FRefreshObject;
61 procedure FindRichEditText(AFindDialog: TFindDialog; ARichEdit: TRichEdit);
62 procedure ReplaceRichEditText(AReplaceDialog: TReplaceDialog; ARichEdit: TRichEdit);
63 end;
64
65var
66 dmodShared: TdmodShared;
67
68const
69 ObjMarker = '^@@^';
70 ObjMarkerLen = length(ObjMarker);
71 DlgPropMarker = '^@=';
72 DlgPropMarkerLen = length(DlgPropMarker);
73 NoTextMarker = '<@>';
74
75implementation
76
77uses fDrawers, rTemplates, uCore, uTemplateFields, uEventHooks, VA508AccessibilityRouter;
78
79{$R *.DFM}
80
81const
82 TemplateImageIdx: array[TTemplateType, Boolean, Boolean] of integer =
83 // Personal Shared
84 // Closed Open Closed Open
85 ((( 0, 0), ( 0, 0)), // ttNone,
86 (( 0, 1), ( 0, 1)), // ttMyRoot
87 (( 0, 1), ( 0, 1)), // ttRoot
88 (( 0, 1), ( 0, 1)), // ttTitles
89 (( 0, 1), ( 0, 1)), // ttConsults
90 (( 0, 1), ( 0, 1)), // ttProcedures
91 (( 2, 3), ( 16, 17)), // ttClass
92 (( 4, 4), ( 10, 10)), // ttDoc
93 (( 5, 6), ( 11, 12)), // ttGroup
94 (( 7, 7), ( 13, 13)), // ttDocEx
95 (( 8, 9), ( 14, 15))); // ttGroupEx
96
97 DialogConvMax = 7;
98 DialogImageXRef: array[0..DialogConvMax, Boolean] of integer =
99 ((5,18), (6,19),
100 (8,20), (9,21),
101 (11,22),(12,23),
102 (14,24),(15,25));
103
104 RemDlgIdx: array[boolean] of integer = (26, 27);
105 COMObjIdx: array[boolean] of integer = (29, 28);
106
107function TdmodShared.ImgIdx(Node: TTreeNode): integer;
108var
109 Typ: TTemplateType;
110 i: integer;
111
112begin
113 Result := -1;
114 if(assigned(Node.Data)) then
115 begin
116 with TTemplate(Node.Data) do
117 begin
118 if (RealType = ttDoc) and (IsReminderDialog) then
119 Result := RemDlgIdx[(PersonalOwner <= 0)]
120 else
121 if (RealType = ttDoc) and (IsCOMObject) then
122 Result := COMObjIdx[COMObjectOK(COMObject)]
123 else
124 begin
125 Typ := TemplateType;
126 if(Exclude and (Typ in [ttDocEx, ttGroupEx])) then
127 begin
128 if(not assigned(Node.Parent)) or (TTemplate(Node.Parent.Data).RealType <> ttGroup) then
129 begin
130 case Typ of
131 ttDocEx: Typ := ttDoc;
132 ttGroupEx: Typ := ttGroup;
133 end;
134 end;
135 end;
136 Result := TemplateImageIdx[Typ, (PersonalOwner <= 0),
137 (Node.Expanded and Node.HasChildren)];
138 if(Dialog and (Typ in [ttGroup, ttGroupEx])) then
139 begin
140 for i := 0 to DialogConvMax do
141 begin
142 if(Result = DialogImageXRef[i, FALSE]) then
143 begin
144 Result := DialogImageXRef[i, TRUE];
145 break;
146 end;
147 end;
148 end;
149 end;
150 end;
151 end;
152end;
153
154procedure TdmodShared.AddTemplateNode(Tree: TTreeView; var EmptyCount: integer;
155 const tmpl: TTemplate; AllowInactive: boolean = FALSE;
156 const Owner: TTreeNode = nil);
157var
158 Cur, Next: TTreeNode;
159 Done: boolean;
160 NewNode: TTreeNode;
161
162 procedure AddChildObject(Owner: TTreeNode);
163 begin
164 NewNode := Tree.Items.AddChildObject(Owner, tmpl.PrintName, tmpl);
165 TORTreeNode(NewNode).StringData := tmpl.ID + U + tmpl.PrintName;
166 NewNode.Cut := not tmpl.Active;
167 tmpl.AddNode(NewNode);
168 Done := TRUE;
169 end;
170
171begin
172 if((assigned(tmpl)) and ((tmpl.Active) or AllowInactive)) then
173 begin
174 Done := FALSE;
175 NewNode := nil;
176 if(assigned(Owner)) then
177 begin
178 Cur := Owner.GetFirstChild;
179 if(not assigned(Cur)) then
180 AddChildObject(Owner);
181 end
182 else
183 begin
184 Cur := Tree.Items.GetFirstNode;
185 if(not assigned(Cur)) then
186 AddChildObject(nil);
187 end;
188 if(not Done) then
189 begin
190 repeat
191 if(Cur.Data = tmpl) then
192 Done := TRUE
193 else
194 begin
195 Next := Cur.GetNextSibling;
196 if(assigned(Next)) then
197 Cur := Next
198 else
199 AddChildObject(Owner);
200 end;
201 until Done;
202 end;
203 if(assigned(NewNode) and (InEditor or (not tmpl.HideItems)) and
204 ((tmpl.Children in [tcActive, tcBoth]) or
205 ((tmpl.Children <> tcNone) and AllowInactive))) then
206 begin
207 Tree.Items.AddChild(NewNode, EmptyNodeText);
208 inc(EmptyCount);
209 end;
210 end;
211end;
212
213function TdmodShared.ExpandNode(Tree: TTreeView; Node: TTreeNode;
214 var EmptyCount: integer; AllowInactive: boolean = FALSE): boolean;
215
216var
217 TmpNode: TTreeNode;
218 tmpl: TTemplate;
219 i :integer;
220
221begin
222 TmpNode := Node.GetFirstChild;
223 Result := TRUE;
224 if((assigned(TmpNode)) and (TmpNode.Text = EmptyNodeText)) then
225 begin
226 TmpNode.Delete;
227 dec(EmptyCount);
228 tmpl := TTemplate(Node.Data);
229 ExpandTemplate(tmpl);
230 for i := 0 to tmpl.Items.Count-1 do
231 AddTemplateNode(Tree, EmptyCount, TTemplate(tmpl.Items[i]),
232 AllowInactive, Node);
233 if((tmpl.Children = tcNone) or ((not AllowInactive) and (tmpl.Children = tcInactive))) then
234 Result := FALSE;
235 end;
236end;
237
238procedure TdmodShared.Resync(SyncNode: TTreeNode; AllowInactive: boolean;
239 var EmptyCount: integer);
240var
241 FromGet: boolean;
242 IDCount, SyncLevel, i: integer;
243 SyncExpanded: boolean;
244 //SelNode,
245 Node: TTreeNode;
246 Template: TTemplate;
247 IDSort, CurExp: TStringList;
248 SelID, TopID: string;
249 DoSel, DoTop: boolean;
250 Tree: TTreeView;
251 First: boolean;
252 TagCount: longint;
253
254 function InSyncNode(Node: TTreeNode): boolean;
255 var
256 TmpNode: TTreeNode;
257
258 begin
259 Result := FALSE;
260 TmpNode := Node;
261 while((not Result) and assigned(TmpNode)) do
262 begin
263 if(TmpNode = SyncNode) then
264 Result := TRUE
265 else
266 TmpNode := TmpNode.Parent;
267 end;
268 end;
269
270 function GetID(Node: TTreeNode): string;
271 var
272 tmpl: TTemplate;
273 IDX: string;
274
275 begin
276 inc(IDCount);
277 Result := '';
278 if(assigned(Node) and assigned(Node.Data)) then
279 begin
280 tmpl := TTemplate(Node.Data);
281 if((tmpl.ID = '') or (tmpl.ID = '0')) then
282 begin
283 if(tmpl.LastTagIndex <> FTagIndex) then
284 begin
285 tmpl.LastTagIndex := FTagIndex;
286 inc(TagCount);
287 tmpl.tag := TagCount;
288 end;
289 IDX := '<'+IntToStr(tmpl.Tag)+'>';
290 end
291 else
292 IDX := tmpl.ID;
293 if(Node <> SyncNode) and (assigned(Node.Parent)) then
294 Result := U + GetID(Node.Parent);
295 Result := IDX + Result;
296 end;
297 dec(IDCount);
298 if((not FromGet) and (IDCount = 0) and (Result <> '')) then
299 Result := IntToStr(Node.AbsoluteIndex) + U + Result;
300 end;
301
302 function GetNode(ID: string): TTreeNode;
303 var
304 idx, i :integer;
305 TrueID, TmpStr: string;
306 TmpNode: TTreeNode;
307
308 begin
309 Result := nil;
310 if(ID <> '') then
311 begin
312 idx := StrToIntDef(Piece(ID,U,1),0);
313 i := pos(U,ID);
314 if(i > 0) then
315 begin
316 delete(ID,1,i);
317 FromGet := TRUE;
318 try
319 TmpNode := SyncNode.GetFirstChild;
320 while ((not assigned(Result)) and (assigned(TmpNode)) and
321 (TmpNode.Level > SyncLevel)) do
322 begin
323 if(GetID(TmpNode) = ID) then
324 Result := TmpNode
325 else
326 TmpNode := TmpNode.GetNext;
327 end;
328 if(not assigned(Result)) then
329 begin
330 TrueID := piece(ID,U,1);
331 TmpNode := SyncNode.GetFirstChild;
332 while ((not assigned(Result)) and (assigned(TmpNode)) and
333 (TmpNode.Level > SyncLevel)) do
334 begin
335 if(assigned(TmpNode.Data) and (TTemplate(TmpNode.Data).ID = TrueID)) then
336 begin
337 TmpStr := IntToStr(abs(idx-TmpNode.AbsoluteIndex));
338 TmpStr := copy('000000',1,7-length(TmpStr))+TmpStr;
339 IDSort.AddObject(TmpStr,TmpNode);
340 end;
341 TmpNode := TmpNode.GetNext;
342 end;
343 if(IDSort.Count > 0) then
344 begin
345 IDSort.Sort;
346 Result := TTreeNode(IDSort.Objects[0]);
347 IDSort.Clear;
348 end;
349 end;
350 finally
351 FromGet := FALSE;
352 end;
353 end;
354 end;
355 end;
356
357 procedure BuildNodes(tmpl: TTemplate; Owner: TTreeNode);
358 var
359 i: integer;
360 TmpNode: TTreeNode;
361
362 begin
363 if(tmpl.Active or AllowInactive) then
364 begin
365 if(First) then
366 begin
367 First := FALSE;
368 TmpNode := Owner;
369 end
370 else
371 begin
372 TmpNode := Tree.Items.AddChildObject(Owner, tmpl.PrintName, tmpl);
373 TORTreeNode(TmpNode).StringData := tmpl.ID + U + tmpl.PrintName;
374 TmpNode.Cut := not tmpl.Active;
375 tmpl.AddNode(TmpNode);
376 end;
377 if(tmpl.Expanded) then
378 begin
379 for i := 0 to tmpl.Items.Count-1 do
380 BuildNodes(TTemplate(tmpl.Items[i]), TmpNode);
381 end
382 else
383 if(InEditor or (not tmpl.HideItems)) and
384 ((tmpl.Children in [tcActive, tcBoth]) or
385 (AllowInactive and (tmpl.Children = tcInactive))) then
386 begin
387 Tree.Items.AddChild(TmpNode, EmptyNodeText);
388 inc(EmptyCount);
389 end;
390 end;
391 end;
392
393begin
394 if(assigned(SyncNode)) then
395 begin
396 TagCount := 0;
397 inc(FTagIndex);
398 Tree := TTreeView(SyncNode.TreeView);
399 Tree.Items.BeginUpdate;
400 try
401 SyncExpanded := SyncNode.Expanded;
402 Template := TTemplate(SyncNode.Data);
403 SyncLevel := SyncNode.Level;
404 FromGet := FALSE;
405 IDCount := 0;
406 IDSort := TStringList.Create;
407 try
408 {-- Get the Current State of the tree --}
409 CurExp := TStringList.Create;
410 try
411 Node := Tree.TopItem;
412 DoTop := InSyncNode(Node);
413 if(DoTop) then
414 TopID := GetID(Node);
415
416 Node := Tree.Selected;
417 DoSel := InSyncNode(Node);
418 if(DoSel) then
419 SelID := GetID(Node);
420
421 Node := SyncNode.GetFirstChild;
422 while ((assigned(Node)) and (Node.Level > SyncLevel)) do
423 begin
424 if(Node.Text = EmptyNodeText) then
425 dec(EmptyCount)
426 else
427 if(Node.Expanded) then
428 CurExp.Add(GetID(Node));
429 if(assigned(Node.Data)) then
430 TTemplate(Node.Data).RemoveNode(Node);
431 Node := Node.GetNext;
432 end;
433
434 {-- Recursively Rebuild the Tree --}
435 SyncNode.DeleteChildren;
436 First := TRUE;
437 BuildNodes(Template, SyncNode);
438
439 {-- Attempt to restore Tree to it's former State --}
440 SyncNode.Expanded := SyncExpanded;
441 for i := 0 to CurExp.Count-1 do
442 begin
443 Node := GetNode(CurExp[i]);
444 if(assigned(Node)) then
445 Node.Expand(FALSE);
446 end;
447
448 if(DoTop) and (TopID <> '') then
449 begin
450 Node := GetNode(TopID);
451 if(assigned(Node)) then
452 Tree.TopItem := Node;
453 end;
454
455 if(DoSel) and (SelID <> '') then
456 begin
457 Node := GetNode(SelID);
458 if(assigned(Node)) then
459 begin
460 Tree.Selected := Node;
461 Node.MakeVisible;
462 end;
463 end;
464
465 finally
466 CurExp.Free;
467 end;
468
469 finally
470 IDSort.Free;
471 end;
472
473 finally
474 Tree.Items.EndUpdate;
475 end;
476 end;
477end;
478
479
480procedure TdmodShared.dmodSharedCreate(Sender: TObject);
481begin
482 FDrawerTrees := TList.Create;
483 imgReminders.Overlay(6,0);
484 imgReminders.Overlay(7,1);
485 imgReminders2.Overlay(4,0);
486end;
487
488procedure TdmodShared.dmodSharedDestroy(Sender: TObject);
489begin
490 KillObj(@FDrawerTrees);
491 KillObj(@FTIUObjects);
492end;
493
494procedure TdmodShared.AddDrawerTree(DrawerForm: TForm);
495begin
496 if(assigned(FDrawerTrees)) and (FDrawerTrees.IndexOf(DrawerForm) < 0) then
497 FDrawerTrees.Add(DrawerForm);
498 Encounter.Notifier.NotifyWhenChanged(EncounterLocationChanged);
499end;
500
501procedure TdmodShared.RemoveDrawerTree(DrawerForm: TForm);
502var
503 idx: integer;
504
505begin
506 if(assigned(FDrawerTrees)) then
507 begin
508 idx := FDrawerTrees.IndexOf(DrawerForm);
509 if(idx >= 0) then
510 FDrawerTrees.Delete(idx);
511 end;
512end;
513
514procedure TdmodShared.Reload;
515var
516 i: integer;
517
518begin
519 if(assigned(FDrawerTrees)) then
520 begin
521 ReleaseTemplates;
522 for i := 0 to FDrawerTrees.Count-1 do
523 TfrmDrawers(FDrawerTrees[i]).ExternalReloadTemplates;
524 end;
525end;
526
527procedure TdmodShared.LoadTIUObjects;
528var
529 i: integer;
530
531begin
532 if(not assigned(FTIUObjects)) or (FRefreshObject = true) then
533 begin
534 if(not assigned(FTIUObjects)) then
535 FTIUObjects := TStringList.Create;
536 FTIUObjects.Clear;
537 GetObjectList;
538 for i := 0 to RPCBrokerV.Results.Count-1 do
539 FTIUObjects.Add(MixedCase(Piece(RPCBrokerV.Results[i],U,2))+U+RPCBrokerV.Results[i]);
540 FTIUObjects.Sort;
541 FRefreshObject := False;
542 end;
543end;
544
545function TdmodShared.NeedsCollapsing(Tree: TTreeView): boolean;
546var
547 Node: TTreeNode;
548
549begin
550 Result := FALSE;
551 if(assigned(Tree)) then
552 begin
553 Node := Tree.Items.GetFirstNode;
554 while((not Result) and assigned(Node)) do
555 begin
556 Result := Node.Expanded;
557 Node := Node.GetNextSibling;
558 end;
559 end;
560end;
561
562function TdmodShared.BoilerplateOK(const Txt, CRDelim: string; ObjList: TStringList;
563 var Err: TStringList): boolean;
564var
565 cnt, i, j, p: integer;
566 tmp,obj: string;
567 BadObj, ok: boolean;
568
569 procedure AddErr(Amsg: string);
570 begin
571 if(not assigned(Err)) then
572 Err := TStringList.Create;
573 Err.Add(Amsg)
574 end;
575
576 function ErrCount: integer;
577 begin
578 if(Assigned(Err)) then
579 Result := Err.Count
580 else
581 Result := 0;
582 end;
583
584begin
585 if(assigned(ObjList)) then
586 ObjList.Clear;
587 cnt := ErrCount;
588 tmp := Txt;
589 BadObj := FALSE;
590 repeat
591 i := pos('|',tmp);
592 if(i > 0) then
593 begin
594 delete(tmp,1,i);
595 j := pos('|',tmp);
596 if(j = 0) then
597 begin
598 AddErr('Unpaired "|" in Boilerplate');
599 continue;
600 end;
601 obj := copy(tmp,1,j-1);
602 delete(tmp,1,j);
603 if(obj = '') then
604 begin
605 AddErr('Brackets "||" are there, but there''s no name inside it.');
606 continue;
607 end;
608 j := pos(CRDelim, obj);
609 if(j > 0) then
610 begin
611 AddErr('Object "'+copy(obj,1,j-1)+'" split between lines');
612 continue;
613 end;
614 LoadTIUObjects;
615 ok := FALSE;
616 for j := 0 to FTIUObjects.Count-1 do
617 begin
618 for p := 3 to 5 do
619 begin
620 if(obj = piece(FTIUObjects[j],U,p)) then
621 begin
622 ok := TRUE;
623 if(assigned(ObjList)) and (ObjList.IndexOf(ObjMarker + obj) < 0) then
624 begin
625 ObjList.Add(ObjMarker + obj);
626 ObjList.Add('|' + obj + '|');
627 end;
628 break;
629 end;
630 end;
631 if(ok) then break;
632 end;
633 if(not ok) then
634 begin
635 AddErr('Object "'+obj+'" not found.');
636 BadObj := TRUE;
637 end;
638 end;
639 until(i=0);
640 Result := (cnt = ErrCount);
641 if(not Result) then
642 begin
643 Err.Insert(0,'Boilerplate Contains Errors:');
644 Err.Insert(1,'');
645 if(BadObj) then
646 begin
647 Err.Add('');
648 Err.Add('Use UPPERCASE and object''s exact NAME, PRINT NAME, or ABBREVIATION');
649 Err.Add('Any of these may have changed since an object was embedded.');
650 end;
651 end;
652 if(assigned(ObjList) and (ObjList.Count > 0)) then
653 ObjList.Add(ObjMarker);
654end;
655
656function TdmodShared.TemplateOK(tmpl: TTemplate; Msg: string = ''): boolean;
657var
658 Err: TStringList;
659 btns: TMsgDlgButtons;
660
661begin
662 Err := nil;
663 try
664 Result := BoilerplateOK(tmpl.FullBoilerplate, #13, nil, Err);
665 if(not Result) then
666 begin
667 if(Msg = 'OK') then
668 btns := [mbOK]
669 else
670 begin
671 btns := [mbAbort, mbIgnore];
672 Err.Add('');
673 if(Msg = '') then
674 Msg := 'template insertion';
675 Err.Add('Do you want to Abort '+Msg+', or Ignore the error and continue?');
676 end;
677 Result := (MessageDlg(Err.Text, mtError, btns, 0) = mrIgnore);
678 end;
679 finally
680 if(assigned(Err)) then
681 Err.Free;
682 end;
683 if Result then
684 Result := BoilerplateTemplateFieldsOK(tmpl.FullBoilerplate, Msg);
685end;
686
687procedure TdmodShared.EncounterLocationChanged(Sender: TObject);
688var
689 i: integer;
690
691begin
692 if(assigned(FDrawerTrees)) then
693 begin
694 for i:= 0 to FDrawerTrees.count-1 do
695 TfrmDrawers(FDrawerTrees[i]).UpdatePersonalTemplates;
696 end;
697end;
698
699procedure TdmodShared.SelectNode(Tree: TORTreeView; GotoNodeID: string; var EmptyCount: integer);
700var
701 i, j: integer;
702 IEN, PIEN: string;
703 Node: TORTreeNode;
704
705 function FindNode(StartNode: TORTreeNode): TORTreeNode;
706 begin
707 Result := nil;
708 while assigned(StartNode) do
709 begin
710 if(Piece(StartNode.StringData, U ,1) = IEN) then
711 begin
712 Result := StartNode;
713 exit;
714 end;
715 StartNode := TORTreeNode(StartNode.GetNextSibling);
716 end;
717 end;
718
719begin
720 if(GotoNodeID <> '') then
721 begin
722 i := 1;
723 for j := 1 to length(GotoNodeID) do
724 if(GotoNodeID[j] = ';') then inc(i);
725 PIEN := '';
726 Node := TORTreeNode(Tree.Items.GetFirstNode);
727 repeat
728 IEN := piece(GotoNodeID, ';', i);
729 if(IEN <> '') then
730 begin
731 Node := FindNode(Node);
732 if(assigned(Node)) then
733 begin
734 if(PIEN <> '') then
735 PIEN := ';' + PIEN;
736 PIEN := IEN + PIEN;
737 if(PIEN = GotoNodeID) then
738 begin
739 Node.EnsureVisible;
740 Tree.Selected := Node;
741 IEN := '';
742 end
743 else
744 begin
745 dmodShared.ExpandNode(Tree, Node, EmptyCount);
746 Node := TORTreeNode(Node.GetFirstChild);
747 if(assigned(Node)) then
748 dec(i)
749 else
750 IEN := '';
751 end;
752 end
753 else
754 IEN := '';
755 end;
756 until (i < 1) or (IEN = '');
757 end;
758end;
759
760function TdmodShared.InDialog(Node: TTreeNode): boolean;
761begin
762 Result := FALSE;
763 while assigned(Node) and (not Result) do
764 begin
765 if TTemplate(Node.Data).IsDialog then
766 Result := TRUE
767 else
768 Node := Node.Parent;
769 end;
770end;
771
772procedure TdmodShared.ExpandTree(Tree: TORTreeView; ExpandString: string;
773 var EmptyCount: integer; AllowInactive: boolean = FALSE);
774
775var
776 NStr: string;
777 i: integer;
778 Node: TTreeNode;
779
780begin
781 Tree.Items.BeginUpdate;
782 try
783 i := 1;
784 repeat
785 NStr := piece(ExpandString,U,i);
786 if(NStr <> '') then
787 begin
788 inc(i);
789 Node := Tree.FindPieceNode(NStr, 1, ';');
790 if assigned(Node) then
791 begin
792 ExpandNode(Tree, Node, EmptyCount, AllowInactive);
793 Node.Expand(False);
794 end;
795 end;
796 until(NStr = '');
797 finally
798 Tree.Items.EndUpdate;
799 end;
800end;
801
802procedure TdmodShared.FindRichEditText(AFindDialog: TFindDialog; ARichEdit: TRichEdit);
803const
804 TX_NOMATCH = 'The text was not found';
805 TC_NOMATCH = 'No more matches';
806var
807 FoundAt, FoundLine, TopLine, BottomLine: LongInt;
808 StartPos, ToEnd, CharPos: Integer;
809 SearchOpts: TSearchTypes;
810begin
811 SearchOpts := [];
812 with ARichEdit do
813 begin
814 SetFocus;
815 { begin the search after the current selection if there is one }
816 { otherwise, begin at the start of the text }
817 if SelStart <> 0 then
818 StartPos := SelStart + SelLength
819 else
820 StartPos := 0;
821 { ToEnd is the length from StartPos to the end of the text in the rich edit control }
822 ToEnd := Length(Text) - StartPos;
823 if frMatchCase in AFindDialog.Options then Include(SearchOpts, stMatchCase);
824 if frWholeWord in AFindDialog.Options then Include(SearchOpts, stWholeWord);
825 FoundAt := FindText(AFindDialog.FindText, StartPos, ToEnd, SearchOpts);
826 if FoundAt <> -1 then
827 begin
828 SetFocus;
829 TopLine := SendMessage(Handle, EM_GETFIRSTVISIBLELINE, 0, 0);
830 BottomLine := TopLine + (Height div FontHeightPixel(Font.Handle));
831 FoundLine := SendMessage(Handle, EM_EXLINEFROMCHAR, 0, FoundAt);
832 if (FoundLine + 10) > BottomLine then
833 SendMessage(Handle, EM_LINESCROLL, 0, FoundLine - BottomLine + 10);
834 CharPos := Pos(AFindDialog.FindText, Lines[FoundLine]);
835 SendMessage(ARichEdit.Handle, EM_LINESCROLL, CharPos, 0);
836 SelStart := FoundAt;
837 SelLength := Length(AFindDialog.FindText);
838 end
839 else
840 begin
841 if not (frReplaceAll in AFindDialog.Options) then InfoBox(TX_NOMATCH, TC_NOMATCH, MB_OK);
842 SelStart := 0;
843 SelLength := 0;
844 Windows.SetFocus(AFindDialog.Handle);
845 //AFindDialog.CloseDialog;
846 end;
847 end;
848end;
849
850procedure TdmodShared.ReplaceRichEditText(AReplaceDialog: TReplaceDialog; ARichEdit: TRichEdit);
851const
852 TC_COMPLETE = 'Replacement Complete';
853 TX_COMPLETE1 = 'CPRS has finished searching the document. ' + CRLF;
854 TX_COMPLETE2 = ' replacements were made.';
855var
856 Replacements: integer;
857 NewStart: integer;
858begin
859 Replacements := 0;
860 if (frReplace in AReplaceDialog.Options) then
861 begin
862 if ARichEdit.SelLength > 0 then
863 begin
864 NewStart := ARichEdit.SelStart + Length(AReplaceDialog.ReplaceText);
865 ARichEdit.SelText := AReplaceDialog.ReplaceText;
866 ARichEdit.SelStart := NewStart;
867 //Replacements := Replacements + 1;
868 end;
869 FindRichEditText(AReplaceDialog, ARichEdit);
870 end
871 else if (frReplaceAll in AReplaceDialog.Options) then
872 begin
873 repeat
874 if ARichEdit.SelLength > 0 then
875 begin
876 NewStart := ARichEdit.SelStart + Length(AReplaceDialog.ReplaceText);
877 ARichEdit.SelText := AReplaceDialog.ReplaceText;
878 ARichEdit.SelStart := NewStart;
879 Replacements := Replacements + 1;
880 end;
881 FindRichEditText(AReplaceDialog, ARichEdit);
882 until ARichEdit.SelLength = 0;
883 InfoBox(TX_COMPLETE1 + IntToStr(Replacements) + TX_COMPLETE2, TC_COMPLETE, MB_OK);
884 end
885 else
886 FindRichEditText(AReplaceDialog, ARichEdit);
887end;
888
889initialization
890 SpecifyFormIsNotADialog(TdmodShared);
891
892end.
893
894
895
896
897
Note: See TracBrowser for help on using the repository browser.