Module

mTreeGrid

Path

C:\CPRS\CPRS30\mTreeGrid.pas

Last Modified

7/15/2014 3:26:40 PM

Classes

Name Comments
TLexTreeNode -
TTreeGridFrame -

Procedures

Name Owner Declaration Scope Comments
ClearData TTreeGridFrame procedure ClearData; Public TTreeGridFrame
CMFontChanged TTreeGridFrame procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED; Protected -
pnlTopResize TTreeGridFrame procedure pnlTopResize(Sender: TObject); Public/Published -
PopulatePanels TTreeGridFrame procedure PopulatePanels; Private -
ResizePanels TTreeGridFrame procedure ResizePanels; Private -
SetCodeTitle TTreeGridFrame procedure SetCodeTitle(const Value: string); Private -
SetColumnTreeModel TTreeGridFrame procedure SetColumnTreeModel(ResultSet: TStrings); Public Public declarations
SetDescTitle TTreeGridFrame procedure SetDescTitle(const Value: string); Private -
SetHorizPanelSpace TTreeGridFrame procedure SetHorizPanelSpace(const Value: integer); Private -
SetSelectedNode TTreeGridFrame procedure SetSelectedNode(const Value: TLexTreeNode); Private -
SetSeparatorSpace TTreeGridFrame procedure SetSeparatorSpace(const Value: integer); Private -
SetShowCode TTreeGridFrame procedure SetShowCode(const Value: boolean); Private -
SetShowDescription TTreeGridFrame procedure SetShowDescription(const Value: boolean); Private -
SetShowTargetCode TTreeGridFrame procedure SetShowTargetCode(const Value: boolean); Private -
SetTargetTitle TTreeGridFrame procedure SetTargetTitle(const Value: string); Private -
SetTitle TTreeGridFrame procedure SetTitle(const Value: string); Private -
SetVertPanelSpace TTreeGridFrame procedure SetVertPanelSpace(const Value: integer); Private -
tvChange TTreeGridFrame procedure tvChange(Sender: TObject; Node: TTreeNode); Public/Published -
tvCreateNodeClass TTreeGridFrame procedure tvCreateNodeClass(Sender: TCustomTreeView; var NodeClass: TTreeNodeClass); Public/Published -

Functions

Name Owner Declaration Scope Comments
FindNode TTreeGridFrame function FindNode(AValue:String): TLexTreeNode; Public -
GetCodeTitle TTreeGridFrame function GetCodeTitle: string; Private -
GetDescTitle TTreeGridFrame function GetDescTitle: string; Private -
GetSelectedNode TTreeGridFrame function GetSelectedNode: TLexTreeNode; Private -
GetSeparatorSpace TTreeGridFrame function GetSeparatorSpace: integer; Private -
GetShowCode TTreeGridFrame function GetShowCode: boolean; Private -
GetShowDescription TTreeGridFrame function GetShowDescription: boolean; Private -
GetShowTargetCode TTreeGridFrame function GetShowTargetCode: boolean; Private -
GetTargetTitle TTreeGridFrame function GetTargetTitle: string; Private -
GetTitle TTreeGridFrame function GetTitle: string; Private -
NumLinesWrapped TTreeGridFrame function NumLinesWrapped(mmo: TMemo): integer; Private -

Constants

Name Declaration Scope Comments
BUTTON_SIZE 5 Global -
TreeExpanderSpacing 6 Global -


Module Source

1     unit mTreeGrid;
2     
3     interface
4     
5     uses
6       Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
7       Types, Dialogs, ComCtrls, Themes, UxTheme, ORFn, ExtCtrls, StdCtrls;
8     
9     type
10    
11      TLexTreeNode = class(TTreeNode)
12      private
13        FVUID: string;
14        FCode: string;
15        FCodeSys: string;
16        FCodeIEN: string;
17        FCodeDescription: string;
18        FTargetCodeSys: string;
19        FTargetCode: string;
20        FTargetCodeIEN: string;
21        FTargetCodeDescription: string;
22        FParentIndex: string;
23        FResultLine: string;
24      public
25    //    Columns: TStrings;
26        property VUID: string read FVUID write FVUID;
27        property Code: string read FCode write FCode;
28        property CodeSys: string read FCodeSys write FCodeSys;
29        property CodeIEN: string read FCodeIEN write FCodeIEN;
30        property CodeDescription: string read FCodeDescription write FCodeDescription;
31        property TargetCode: string read FTargetCode write FTargetCode;
32        property TargetCodeSys: string read FTargetCodeSys write FTargetCodeSys;
33        property TargetCodeIEN: string read FTargetCodeIEN write FTargetCodeIEN;
34        property TargetCodeDescription: string read FTargetCodeDescription write FTargetCodeDescription;
35        property ParentIndex: string read FParentIndex write FParentIndex;
36        property ResultLine: string read fResultLine write FResultLine;
37      end;
38    
39      TTreeGridFrame = class(TFrame)
40        tv: TTreeView;
41        pnlTop: TPanel;
42        stTitle: TStaticText;
43        pnlSpace: TPanel;
44        pnlHint: TPanel;
45        pnlTarget: TPanel;
46        mmoTargetCode: TMemo;
47        pnlTargetCodeSys: TPanel;
48        pnlCode: TPanel;
49        mmoCode: TMemo;
50        pnlCodeSys: TPanel;
51        pnlDesc: TPanel;
52        mmoDesc: TMemo;
53        pnlDescText: TPanel;
54        procedure tvCreateNodeClass(Sender: TCustomTreeView;
55          var NodeClass: TTreeNodeClass);
56        procedure tvChange(Sender: TObject; Node: TTreeNode);
57        procedure pnlTopResize(Sender: TObject);
58      private
59        fHorizPanelSpace: integer;
60        fVertPanelSpace: integer;
61        fShowDesc: boolean;
62        fShowCode: boolean;
63        fShowTargetCode: boolean;
64        function GetSelectedNode: TLexTreeNode;
65        procedure SetSelectedNode(const Value: TLexTreeNode);
66        procedure SetShowCode(const Value: boolean);
67        procedure SetShowDescription(const Value: boolean);
68        procedure SetShowTargetCode(const Value: boolean);
69        function GetTitle: string;
70        procedure SetTitle(const Value: string);
71        procedure ResizePanels;
72        procedure PopulatePanels;
73        procedure SetHorizPanelSpace(const Value: integer);
74        function GetShowCode: boolean;
75        function GetShowDescription: boolean;
76        function GetShowTargetCode: boolean;
77        procedure SetVertPanelSpace(const Value: integer);
78        procedure SetCodeTitle(const Value: string);
79        procedure SetDescTitle(const Value: string);
80        procedure SetTargetTitle(const Value: string);
81        function GetCodeTitle: string;
82        function GetDescTitle: string;
83        function GetTargetTitle: string;
84        function NumLinesWrapped(mmo: TMemo): integer;
85        function GetSeparatorSpace: integer;
86        procedure SetSeparatorSpace(const Value: integer);
87      protected
88        procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
89      public
90        { Public declarations }
91        procedure SetColumnTreeModel(ResultSet: TStrings);
92        function FindNode(AValue:String): TLexTreeNode;
93        property SelectedNode: TLexTreeNode read GetSelectedNode write SetSelectedNode;
94        property ShowDescription: boolean read GetShowDescription write SetShowDescription;
95        property ShowCode: boolean read GetShowCode write SetShowCode;
96        property ShowTargetCode: boolean read GetShowTargetCode write SetShowTargetCode;
97        property Title: string read GetTitle write SetTitle;
98        property HorizPanelSpace: integer read fHorizPanelSpace write SetHorizPanelSpace;
99        property VertPanelSpace: integer read fVertPanelSpace write SetVertPanelSpace;
100       property DescTitle: string read GetDescTitle write SetDescTitle;
101       property CodeTitle: string read GetCodeTitle write SetCodeTitle;
102       property TargetTitle: string read GetTargetTitle write SetTargetTitle;
103       property SeparatorSpace: integer read GetSeparatorSpace write SetSeparatorSpace;
104       procedure ClearData;
105     end;
106   
107   implementation
108   
109   uses Math;
110   
111   {$R *.dfm}
112   
113   const
114     BUTTON_SIZE = 5;
115     TreeExpanderSpacing = 6;
116   
117   { TTreeGridFrame }
118   
119   procedure TTreeGridFrame.ClearData;
120   begin
121     tv.Items.Clear;
122     if assigned(pnlHint) then begin
123       fShowDesc := False;
124       fShowCode := False;
125       fShowTargetCode := False;
126       SelectedNode := nil;  // fires off populate panels
127     end;
128   end;
129   
130   procedure TTreeGridFrame.CMFontChanged(var Message: TMessage);
131   begin
132     inherited;
133     ResizePanels;
134   end;
135   
136   function TTreeGridFrame.FindNode(AValue: string): TLexTreeNode;
137   var
138     Node: TLexTreeNode; // Current search node
139     SearchText: string;    // search text
140     StarPos: integer;      // position of indicator
141   begin
142     AValue := Uppercase(AValue);
143     Result := nil;
144     if (tv.Items.Count <> 0) then begin
145       Node := TLexTreeNode(tv.Items[0]);
146       repeat
147         StarPos := Pos(' *', Node.Text);
148         if (StarPos > 0) then
149           SearchText := UpperCase(Copy(Node.Text, 1, StarPos - 1))
150         else
151           SearchText := UpperCase(Node.Text);
152   
153         if (SearchText = AValue) then begin
154           Result := Node;
155           Result.MakeVisible;
156           Result.Selected := True;
157         end;
158         Node := TLexTreeNode(Node.GetNext);
159       until (assigned(Result) or (Node = nil));
160     end;
161   end;
162   
163   function TTreeGridFrame.GetCodeTitle: string;
164   begin
165     Result := pnlCodeSys.Caption;
166   end;
167   
168   function TTreeGridFrame.GetDescTitle: string;
169   begin
170     Result := pnlDescText.Caption;
171   end;
172   
173   function TTreeGridFrame.GetTargetTitle: string;
174   begin
175     Result := pnlTargetCodeSys.Caption;
176   end;
177   
178   function TTreeGridFrame.GetSelectedNode: TLexTreeNode;
179   begin
180     Result := TLexTreeNode(tv.Selected);
181   end;
182   
183   function TTreeGridFrame.GetSeparatorSpace: integer;
184   begin
185     Result := pnlSpace.Height;
186   end;
187   
188   function TTreeGridFrame.GetShowCode: boolean;
189   begin
190     Result := fShowCode;
191   end;
192   
193   function TTreeGridFrame.GetShowDescription: boolean;
194   begin
195     Result := fShowDesc;
196   end;
197   
198   function TTreeGridFrame.GetShowTargetCode: boolean;
199   begin
200     Result := fShowTargetCode;
201   end;
202   
203   function TTreeGridFrame.GetTitle: string;
204   begin
205     Result := stTitle.Caption;
206   end;
207   
208   function TTreeGridFrame.NumLinesWrapped(mmo: TMemo): integer;
209   var
210     sl: TStringList;
211     c: TCanvas;
212   begin
213     c := TCanvas.Create;
214     c.Font.Assign(mmo.Font);
215     try
216       c.Handle := GetDC(0);
217       sl := WrapTextByPixels(mmo.lines.Text, mmo.Width, c, PreSeparatorChars, PostSeparatorChars);
218       if assigned(sl) then begin
219         Result := sl.Count;
220         sl.Free;
221       end else begin
222         Result := 1;
223       end;
224     finally
225       if assigned(c) then c.Free;
226     end;
227   end;
228   
229   procedure TTreeGridFrame.pnlTopResize(Sender: TObject);
230   begin
231     ResizePanels;
232   end;
233   
234   procedure TTreeGridFrame.PopulatePanels;
235   begin
236     if assigned(SelectedNode) then begin
237       if mmoDesc.Visible then begin
238         mmoDesc.Lines.Text := SelectedNode.CodeDescription;
239       end;
240       if pnlCodeSys.Visible and (SelectedNode.CodeSys <> '') then begin
241         CodeTitle := SelectedNode.CodeSys + ':  ';
242       end;
243       if mmoCode.Visible and (SelectedNode.Code <> '') then begin
244         mmoCode.Lines.Text := SelectedNode.Code;
245       end;
246       if pnlTargetCodeSys.Visible and (SelectedNode.TargetCodeSys <> '') then begin
247         TargetTitle := SelectedNode.TargetCodeSys + ':  ';
248       end;
249       if mmoTargetCode.Visible and (SelectedNode.TargetCode <> '') then begin
250         mmoTargetCode.Lines.Text := SelectedNode.TargetCode;
251       end;
252     end else begin
253       if mmoDesc.Visible then begin
254         mmoDesc.Lines.Clear;
255       end;
256       if mmoCode.Visible then begin
257         mmoCode.Lines.Clear;
258       end;
259       if mmoTargetCode.Visible then begin
260         mmoTargetCode.Lines.Clear;
261       end;
262     end;
263     ResizePanels;
264   end;
265   
266   procedure TTreeGridFrame.ResizePanels;
267   var
268     MinWidth: integer;
269     NumLines: integer;
270     HintHeight: integer;
271   begin
272     MinWidth := 0;
273     HintHeight := 1;
274     if assigned(pnlDesc) then begin
275       if fShowDesc then begin
276         NumLines := NumLinesWrapped(mmoDesc);
277         pnlDesc.Height := TextHeightByFont(Font.Handle, mmoDesc.Lines.Text) * NumLines +
278                           fVertPanelSpace * (NumLines - 1);
279         MinWidth := Max(TextWidthByFont(Font.Handle, pnlDescText.Caption) + fHorizPanelSpace, MinWidth);
280       end else begin
281         pnlDesc.Height := 1;
282       end;
283       inc(HintHeight, pnlDesc.Height);
284     end;
285     if assigned(pnlCode) then begin
286       pnlCode.Top := pnlDesc.Height + 1;
287       if fShowCode then begin
288         NumLines := NumLinesWrapped(mmoCode);
289         pnlCode.Height := TextHeightByFont(Font.Handle, mmoCode.Lines.Text) * NumLines +
290                           fVertPanelSpace * (NumLines - 1);
291         MinWidth := Max(TextWidthByFont(Font.Handle, pnlCodeSys.Caption) + fHorizPanelSpace, MinWidth);
292       end else begin
293         pnlCode.Height := 1;
294       end;
295       inc(HintHeight, pnlCode.Height);
296     end;
297     if assigned(pnlTarget) then begin
298       pnlTarget.Top := pnlCode.Top + pnlCode.Height + 1;
299       if fShowTargetCode then begin
300         NumLines := NumLinesWrapped(mmoTargetCode);
301         pnlTarget.Height := TextHeightByFont(Font.Handle, mmoTargetCode.Lines.Text) * NumLines +
302                            fVertPanelSpace * (NumLines - 1);
303         MinWidth := Max(TextWidthByFont(Font.Handle, pnlTargetCodeSys.Caption) + fHorizPanelSpace, MinWidth);
304       end else begin
305         pnlTarget.Height := 1;
306       end;
307       inc(HintHeight, pnlTarget.Height);
308     end;
309     if assigned(pnlHint) then begin
310       pnlHint.Height := HintHeight;
311     end;
312     if assigned(pnlDesc) then begin
313       pnlDescText.Width := MinWidth;
314     end;
315     if assigned(pnlCode) then begin
316       pnlCodeSys.Width := MinWidth;
317     end;
318     if assigned(pnlTarget) then begin
319       pnlTargetCodeSys.Width := MinWidth;
320     end;
321   end;
322   
323   procedure TTreeGridFrame.SetCodeTitle(const Value: string);
324   begin
325     pnlCodeSys.Caption := Value;
326   end;
327   
328   procedure TTreeGridFrame.SetColumnTreeModel(ResultSet: TStrings);
329   var
330     i: integer;
331     Node: TLexTreeNode;
332     RecStr: string;
333   begin
334     if not assigned(ResultSet) or (ResultSet.Text = '') then begin
335       ClearData;
336     end else begin
337       //  1     2        3      4       5       6         7          8     9
338       //VUID^SCT TEXT^ICDCODE^ICDIEN^CODE SYS^CONCEPT^DESIGNATION^ICDVER^PARENT
339       tv.Items.Clear;
340       tv.Refresh;
341   
342       for i := 0 to ResultSet.Count - 1 do begin
343         RecStr := ResultSet[i];
344         if Piece(RecStr, '^', 2) <> '' then begin
345           if Piece(RecStr, '^', 9) = '' then
346             Node := TLexTreeNode(tv.Items.Add(nil, Piece(RecStr, '^', 2)))
347           else
348             Node := TLexTreeNode(tv.Items.AddChild(tv.Items[(StrToInt(Piece(RecStr, '^', 9))-1)], Piece(RecStr, '^', 2)));
349           Node.ResultLine := RecStr;
350           Node.VUID := Piece(RecStr, '^', 1);
351           Node.Text := Piece(RecStr, '^', 2);
352           Node.CodeDescription := Node.Text;
353           Node.CodeIEN := Piece(RecStr, '^', 4);
354           Node.CodeSys := Piece(RecStr, '^', 5);
355           Node.Code := Piece(RecStr, '^', 6);
356           Node.TargetCode := Piece(RecStr, '^', 3);
357           Node.TargetCodeIEN := Piece(RecStr, '^', 4);
358           Node.TargetCodeSys := Piece(RecStr, '^', 8);
359   
360           if Piece(RecStr, '^', 9) <> '' then
361             Node.ParentIndex := IntToStr(StrToInt(Piece(RecStr, '^', 9)) - 1);
362         end;
363       end;
364       //sort tree nodes
365       tv.AlphaSort(True);
366       tv.Enabled := True;
367       tv.SetFocus;
368     end;
369   end;
370   
371   procedure TTreeGridFrame.SetDescTitle(const Value: string);
372   begin
373     pnlDescText.Caption := Value;
374   end;
375   
376   procedure TTreeGridFrame.SetHorizPanelSpace(const Value: integer);
377   begin
378     fHorizPanelSpace := Value;
379     ResizePanels;
380   end;
381   
382   procedure TTreeGridFrame.SetTargetTitle(const Value: string);
383   begin
384     pnlTargetCodeSys.Caption := Value;
385   end;
386   
387   procedure TTreeGridFrame.SetSelectedNode(const Value: TLexTreeNode);
388   begin
389     tv.Selected := Value;
390     PopulatePanels;
391   end;
392   
393   procedure TTreeGridFrame.SetSeparatorSpace(const Value: integer);
394   begin
395     pnlSpace.Height := Value;
396   end;
397   
398   procedure TTreeGridFrame.SetShowCode(const Value: boolean);
399   begin
400     fShowCode := Value;
401     ResizePanels;
402   end;
403   
404   procedure TTreeGridFrame.SetShowDescription(const Value: boolean);
405   begin
406     fShowDesc := Value;
407     ResizePanels;
408   end;
409   
410   procedure TTreeGridFrame.SetShowTargetCode(const Value: boolean);
411   begin
412     fShowTargetCode := Value;
413     ResizePanels;
414   end;
415   
416   procedure TTreeGridFrame.SetTitle(const Value: string);
417   begin
418     stTitle.Caption := Value;
419   end;
420   
421   procedure TTreeGridFrame.SetVertPanelSpace(const Value: integer);
422   begin
423     fVertPanelSpace := Value;
424     ResizePanels;
425   end;
426   
427   procedure TTreeGridFrame.tvChange(Sender: TObject; Node: TTreeNode);
428   begin
429     SelectedNode := TLexTreeNode(Node);
430   end;
431   
432   procedure TTreeGridFrame.tvCreateNodeClass(Sender: TCustomTreeView;
433     var NodeClass: TTreeNodeClass);
434   begin
435     NodeClass := TLexTreeNode;
436   end;
437   
438   end.

Module Calls (2 levels)

-

Module Called-By (2 levels)


              mTreeGrid
              fPCELex┤ 
  fBALocalDiagnoses┤ │ 
         fDiagnoses┤ │ 
       fPCEBaseMain┤ │ 
fBAOptionsDiagnoses┤ │ 
         fODConsult┤ │ 
            fODProc┤ │ 
          fEditProc┤ │ 
       fEditConsult┘ │ 
             fProbLex┘ 
             fProbs┤   
           fProbEdt┘