Changeset 492 for cprs/branches/GUI-config/CPRS-Lib/ORCtrls.pas

Timestamp:

Sep 17, 2008, 5:34:43 PM (16 years ago)

Author:

Kevin Toppenberg

Message:

Resync

File:

• cprs/branches/GUI-config/CPRS-Lib/ORCtrls.pas (modified) (32 diffs)

cprs/branches/GUI-config/CPRS-Lib/ORCtrls.pas

@@ -21 +21 @@
 
 type
+
+  TORStaticText = class(TStaticText)
+  private
+     FOnEnter: TNotifyEvent;
+     FOnExit: TNotifyEvent;
+  published
+     property OnEnter: TNotifyEvent read FOnEnter write FOnEnter;
+     property OnExit: TNotifyEvent read FOnExit write FOnExit;
+     procedure DoEnter; override;
+     procedure DoExit; override;
+  end;
+
   TORComboBox = class;                           // forward declaration for FParentCombo
 
@@ -230 +242 @@
     property MItems: TStrings read GetMItems write SetMItems;
     procedure MakeAccessible(Accessible: IAccessible);
+    function VerifyUnique(SelectIndex: Integer; iText: String): integer;
   published
     property AllowGrayed: boolean read FAllowGrayed write FAllowGrayed default FALSE;
@@ -325 +338 @@
     FCheckBoxEditColor: TColor;                  // Edit Box color for Check Box Combo List, when not in Focus
     FTemplateField: boolean;
+    FCharsNeedMatch: integer;                    // how many text need to be matched for auto selection
+    FUniqueAutoComplete: Boolean;                // If true only perform autocomplete for unique list items.
     function EditControl: TWinControl;
     procedure AdjustSizeOfSelf;
@@ -342 +357 @@
     procedure FwdNeedData(Sender: TObject; const StartFrom: string;
       Direction, InsertAt: Integer);
+    procedure SetNumForMatch(const NumberForMatch: integer);
     function GetAutoSelect: Boolean;
     function GetColor: TColor;
@@ -423 +439 @@
     function GetLookupPiece: integer;
     procedure SetLookupPiece(const Value: integer);
+    procedure SetUniqueAutoComplete(const Value: Boolean);
   protected
     procedure DropPanelBtnPressed(OKBtn, AutoClose: boolean);
@@ -441 +458 @@
     procedure InitLongList(S: string);
     procedure InsertSeparator;
+    procedure SetTextAutoComplete(TextToMatch : String);
     function GetIEN(AnIndex: Integer): Int64;
     function SelectByIEN(AnIEN: Int64): Integer;
@@ -522 +540 @@
     property OnResize;
     property OnSynonymCheck: TORSynonymCheckEvent read GetOnSynonymCheck write SetOnSynonymCheck;
+    property CharsNeedMatch: integer  read FCharsNeedMatch  write SetNumForMatch;
+{UniqueAutoComplete Was added as a result of the following defects:
+ 7293 - PTM 85:  Backspace and Dosage:  Desired dosage does not populate if dosage is not in local dosage field
+ 7337 - PTM 160 Meds: #8 IMO - Simple - Change Order in which Error generated if "Enter" is hit instead of "OK"
+ 7278 - PTM 36 Meds: Select 40000 UNT/2ML and backspace to 4000 the dose selected remains 40000
+ 7284 - Inconsistencies of pulling in a dose from the Possible Dose File }
+    property UniqueAutoComplete: Boolean read FUniqueAutoComplete write SetUniqueAutoComplete default False;
   end;
 
@@ -776 +801 @@
     procedure WMSize           (var Message: TWMSize);          message WM_SIZE;
     procedure BMSetCheck       (var Message: TMessage);         message BM_SETCHECK;
+    procedure BMGetCheck       (var Message: TMessage);         message BM_GETCHECK;
+    procedure BMGetState       (var Message: TMessage);         message BM_GETSTATE;
     function GetImageList: TCustomImageList;
     function GetImageIndexes: string;
@@ -874 +901 @@
   TCaptionListBox = class(TListBox)
   private
+    FHoverItemPos: integer;
     FAccessible: IAccessible;
     FRightClickSelect: boolean;                  // When true, a right click selects teh item
+    FHintOnItem: boolean;
     procedure SetCaption(const Value: string);
     function GetCaption: string;
     procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT;
     procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;
+    procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
   protected
     FCaptionComponent: TStaticText;
+    procedure DoEnter; override;
   public
     procedure MakeAccessible( Accessible: IAccessible);
@@ -887 +918 @@
     property RightClickSelect: boolean read FRightClickSelect write FRightClickSelect default FALSE;
     property Caption: string read GetCaption write SetCaption;
+    //Make the ListBox's hint contain the contents of the listbox Item the mouse is currently over.
+    property HintOnItem: boolean read FHintOnItem write FHintOnItem default FALSE;
   end;
 
@@ -918 +951 @@
     property Align;
     property Caption: string read GetCaption write SetCaption;
+  end;
+
+  TCaptionRichEdit = class(TRichEdit)
+  private
+    FAccessible: IAccessible;
+    procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT;
+  protected
+    FCaption: string;
+  public
+    procedure MakeAccessible(Accessible: IAccessible);
+  published
+    property Align;
+    property Caption: string read FCaption write FCaption;
   end;
 
@@ -961 +1007 @@
 function CalcShortName( LongName: string; PrevLongName: string): string;
 
+{Returns True if any one of 3 mouse buttons are down left, right, or middle}
+function IsAMouseButtonDown : boolean;
+
 implementation  // ---------------------------------------------------------------------------
 
@@ -1006 +1055 @@
     FPoint: TPoint;
     FSelected: boolean;
+    FTabs: array[0..MAX_TABS] of Integer;         // Holds the pixel offsets for tabs
+    procedure GetTabSettings;
   protected
     constructor Create(AOwner: TComponent); override;
@@ -1054 +1105 @@
 begin
   DC := GetDC(0);
-  SaveFont := SelectObject(DC, FontHandle);
-  GetTextExtentPoint32(DC, 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz', 52, Extent);
-  Result := Trunc((Extent.cx / 26 + 1) / 2);     // Round() doesn't line up with dialog units
-  SelectObject(DC, SaveFont);
-  ReleaseDC(0, DC);
+  try
+    SaveFont := SelectObject(DC, FontHandle);
+    try
+      GetTextExtentPoint32(DC, 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz', 52, Extent);
+      Result := Trunc((Extent.cx / 26 + 1) / 2);     // Round() doesn't line up with dialog units
+    finally
+      SelectObject(DC, SaveFont);
+    end;
+  finally
+    ReleaseDC(0, DC);
+  end;
 end;
 
@@ -1234 +1291 @@
     y := ((ClientRect.Bottom - ClientRect.Top) - FontHeightPixel(Canvas.Font.Handle)) div 2;
     //TextOut(ClientRect.Left + 1, ClientRect.Top - 1, AString);
-    TabbedTextOut(Handle, 1, y, PChar(AString), Length(AString), FListBox.FTabPix[0],
-      FListBox.FTabPix[1], -1);
+// WARNING - Do NOT change the X pos or the tab starting pos - this will cause a missmatch
+// between the hint window and what the control displayes
+    TabbedTextOut(Handle, 0, y, PChar(AString), Length(AString), MAX_TABS+1, FTabs[0], 0);
   end;
 end;
@@ -1253 +1311 @@
 end;
 
+procedure TItemTip.GetTabSettings;
+var
+  DX, X, i, count: integer;
+  
+begin
+  Count := FListBox.FTabPix[0];
+  FTabs[0] := 1;     // Set first tab stop to location 1 for display purposes
+  if(Count = 1) then
+  begin
+    DX := FListBox.FTabPix[1];
+    X := (DX * 2) - 1;
+  end
+  else
+  begin
+    DX := FontWidthPixel(FListBox.Font.Handle) * 8; // windows tab default is 8 chars
+    X := FListBox.FTabPix[Count];
+    X := Trunc(X / DX) + 1;
+    X := (X * DX) - 1; // get the next tab position after that which is specified
+  end;
+  for i := 1 to MAX_TABS do
+  begin
+    if(i <= Count) then
+      FTabs[i] := FListBox.FTabPix[i] - 1
+    else
+    begin
+      FTabs[i] := X;
+      inc(X, DX);
+    end;
+  end;
+end;
+
 procedure TItemTip.UpdateText(CatchMouse: Boolean);
 var
@@ -1270 +1359 @@
     Canvas.Font.Color := clWindowText;
   end;
-  Caption := FListBox.DisplayText[FListItem];
+  Caption := #9 + FListBox.DisplayText[FListItem];
   if Copy(Caption, 1, 2) = '__' then Caption := ' ';  // so separators don't extend past window
+
+  GetTabSettings;
+
   AWidth := LOWORD(GetTabbedTextExtent(Canvas.Handle, PChar(Caption), Length(Caption),
-    FListBox.FTabPix[0], FListBox.FTabPix[1]));
+    MAX_TABS+1, FTabs[0]));
   // inherent scrollbar may not always be visible in a long list
   if FListBox.LongList
@@ -1355 +1447 @@
       ORCBImages[i].Free;
   end;
+end;
+
+{ TORStaticText }
+
+procedure TORStaticText.DoEnter;
+begin
+  inherited DoEnter;
+  if Assigned(FOnEnter) then
+     FOnEnter(Self);
+end;
+
+procedure TORStaticText.DoExit;
+begin
+  inherited DoExit;
+  if Assigned(FOnExit) then
+     FOnExit(Self);
 end;
 
@@ -1921 +2029 @@
       // 32 bits long, in the high word of WPARAM (16 bits).  Since that won't work - we'll
       // try sending the item index instead.
-      SendMessage(Parent.Handle, WM_COMMAND, MAKELONG(FocusIndex, LBN_SELCHANGE), LPARAM(Handle));
+      //PostMessage() not SendMessage() is Required here for checkboxes, SendMessage() doesn't
+      //Allow the Checkbox state on the control to be updated
+      if CheckBoxes then
+        PostMessage(Parent.Handle, WM_COMMAND, MAKELONG(FocusIndex, LBN_SELCHANGE), LPARAM(Handle))
+      else
+        SendMessage(Parent.Handle, WM_COMMAND, MAKELONG(FocusIndex, LBN_SELCHANGE), LPARAM(Handle));
     end;
     VK_PRIOR:          SetFocusIndex(FocusIndex - FLargeChange);
@@ -2131 +2244 @@
 begin
   //if Items.Count > 0 then SetFocusIndex(TopIndex);  // this seems to cause problems
+  //Fix For ClearQuest: HDS00001576
+  //This fix has been commented out, becuase it causes problems
+{  if (Items.Count > 0) and (Not IsAMouseButtonDown()) and (ItemIndex = -1) then
+    SetFocusIndex(TopIndex);//ItemIndex := TopIndex; }
   inherited DoEnter;
 end;
@@ -3640 +3757 @@
   FEditBox.OnKeyUp := FwdKeyUp;
   FEditBox.Visible := True;
+  fCharsNeedMatch := 1;  
 end;
 
@@ -3749 +3867 @@
 
 procedure TORComboBox.DoEnter;
+{var
+  key : word;}
 { select all the text in the editbox when recieve focus - done first so OnEnter can deselect }
 begin
   //FEditBox.SelectAll;
+  //Fix For ClearQuest: HDS00001576
+  //This fix has been commented out, becuase it causes problems
+{  with FListBox do
+  if (Items.Count > 0) and (Not IsAMouseButtonDown()) and (ItemIndex = -1) then
+  begin
+    key := VK_UP;
+    FwdKeyDown(Self,key,[]);
+    //Calling keyUp after key down creates a better mimic of a Keystroke.
+    FwdKeyUp(Self,key,[]);   //fixes clearquest: HDS00001418
+  end;              }
   inherited DoEnter;
   PostMessage(Handle, UM_GOTFOCUS, 0, 0)
@@ -3800 +3930 @@
   with FEditBox do x := Copy(Text, 1, SelStart);
   FLastInput := x;
-  SelectIndex := FListBox.SelectString(x);
+  SelectIndex := -1;
+  if Length(x) >= CharsNeedMatch then
+    SelectIndex := FListBox.SelectString(x);
+  if (Length(x) < CharsNeedMatch) and (FListBox.ItemIndex > -1) then
+    SelectIndex := FListBox.SelectString(x);
+  if UniqueAutoComplete then
+    SelectIndex := FListBox.VerifyUnique(SelectIndex,x);
   if FListItemsOnly and (SelectIndex < 0) and (x <> '') then
   begin
@@ -3891 +4027 @@
 { passed selected navigation keys to listbox, applies special handling to backspace and F4 }
 var
-  i: Integer;
-  x: string;
+  i,iPos: Integer;
+  x,AString: string;
 begin
   // special case: when default action taken (RETURN) make sure FwdChangeDelayed is called first
@@ -3902 +4038 @@
     if (FStyle = orcsDropDown) and not DroppedDown then DroppedDown := True;
     // handle special case of FocusIndex, WM_KEYDOWN will increment from -1 to 0
-    if FListBox.ItemIndex = -1 then FListBox.FFocusIndex := -1;
+    if FListBox.ItemIndex = -1 then
+    begin
+      FListBox.FFocusIndex := -1;
+      //Move to correct position when Unique AutoComplete is on.
+      if UniqueAutoComplete then
+      begin
+        AString := Copy(FEditBox.Text, 1, SelStart);
+        iPos := SendMessage(FListBox.Handle, LB_FINDSTRING, -1, Longint(PChar(AString)));
+        if iPos = LB_ERR then iPos := -1;
+        if iPos > -1 then
+        begin
+          FListBox.FFocusIndex := iPos-1;
+          FListBox.ItemIndex := FListBox.FFocusIndex;
+        end;
+      end;
+    end;
     FListBox.Perform(WM_KEYDOWN, Key, 1);
   end;
@@ -4703 +4854 @@
   FListBox.CaseChanged := Value;
 end;
-   
+
 function TORComboBox.GetLookupPiece: integer;
 begin
@@ -4747 +4898 @@
   H := ClientHeight;
   W := ClientWidth;
+  if (H = 0) or (W = 0) then exit;
   for i := 0 to Control.ControlCount - 1 do
   begin
@@ -6157 +6309 @@
 end;
 
+procedure TORCheckBox.BMGetCheck(var Message: TMessage);
+begin
+  {This Allows JAWS to report the state when tabbed into or using the read object
+  keys (Ins+Tab)}
+  {if Self.GrayedStyle = gsBlueQuestionMark then
+    Message.Result := BST_INDETERMINATE
+  else}
+  if Self.Checked then
+    Message.Result := BST_CHECKED
+  else
+    Message.Result := BST_UNCHECKED;
+end;
+
+procedure TORCheckBox.BMGetState(var Message: TMessage);
+begin
+  //This gives JAWS ability to read state when spacebar is pressed.
+  //Commented out because JAWS reads states, but inversly. Working with freedom...
+{  if Self.Checked then
+    Message.Result := BST_CHECKED
+  else
+    Message.Result := BST_UNCHECKED;}
+end;
+
 { TORListView }
 
@@ -6310 +6485 @@
 { TCaptionListBox }
 
+procedure TCaptionListBox.DoEnter;
+begin
+  inherited;
+  if HintOnItem then
+    FHoverItemPos := -1; //CQ: 7178 & 9911 - used as last item index for ListBox
+end;
+
 function TCaptionListBox.GetCaption: string;
 begin
@@ -6346 +6528 @@
   else
     inherited;
+end;
+
+procedure TCaptionListBox.WMMouseMove(var Message: TWMMouseMove);
+var
+  i : integer;
+begin
+  inherited;
+  //CQ: 7178 & 9911 - FHoverItemPos should be set to -1 in OnEnter
+  //Make the TListBox's hint contain the contents of the listbox Item the mouse is currently over
+  if HintOnItem then
+  begin
+    i := ItemAtPos(Point(Message.XPos, Message.YPos), true);
+    if i <> FHoverItemPos then
+      Application.CancelHint;
+    if i = -1 then
+      Hint := ''
+    else
+      Hint := Items[i];
+    FHoverItemPos := i;
+  end;
 end;
 
@@ -6451 +6653 @@
 end;
 
+{ TCaptionRichEdit }
+
+procedure TCaptionRichEdit.MakeAccessible(Accessible: IAccessible);
+begin
+  if Assigned(FAccessible) and Assigned(Accessible) then
+    raise Exception.Create(Caption + ' Rich Edit is already Accessible!')
+  else
+    FAccessible := Accessible;
+end;
+
+procedure TCaptionRichEdit.WMGetObject(var Message: TMessage);
+begin
+  if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then
+    Message.Result := GetLResult(Message.wParam, FAccessible)
+  else
+    inherited;
+end;
 
 { TCaptionTreeView}
@@ -6558 +6777 @@
 end;
 
+function IsAMouseButtonDown : boolean;
+begin
+  if Boolean(Hi(GetKeyState(VK_MBUTTON))) or
+     Boolean(Hi(GetKeyState(VK_LBUTTON))) or
+     Boolean(Hi(GetKeyState(VK_RBUTTON))) then
+    Result := true
+  else
+    Result := false;
+end;
+
+procedure TORComboBox.SetNumForMatch(const NumberForMatch: integer);
+begin
+  if NumberForMatch < 1 then
+    FCharsNeedMatch := 1
+  else if NumberForMatch > 15 then
+    FCharsNeedMatch := 15
+  else
+    FCharsNeedMatch := NumberForMatch;
+end;
+
+procedure TORComboBox.SetUniqueAutoComplete(const Value: Boolean);
+begin
+  FUniqueAutoComplete := Value;
+end;
+
+function TORListBox.VerifyUnique(SelectIndex: Integer; iText: String): integer;
+var
+  i : integer;
+  counter : integer;
+begin
+  Result := SelectIndex;
+    if LongList then
+    begin
+      //Currently Do nothing for LongLists
+     { if CompareText(iText, Copy(DisplayText[SelectIndex+1], 1, Length(iText))) = 0 then
+        Result := -1;}
+    end
+    else //Not a LongList
+    begin
+      counter := 0;
+      for i := 0 to Items.Count-1 do
+        if CompareText(iText, Copy(DisplayText[i], 1, Length(iText))) = 0 then
+          Inc(counter);
+      if counter > 1 then
+        Result := -1; 
+    end;
+  FFocusIndex := Result;
+  ItemIndex := Result; 
+end;
+
+//This procedure sets the Text property equal to the TextToMatch parameter, then calls
+//FwdChangeDelayed which will perform an auto-completion on the text.
+procedure TORComboBox.SetTextAutoComplete(TextToMatch: String);
+begin
+  Text := TextToMatch;
+  SelStart := Length(Text);
+  FwdChangeDelayed;
+end;
+
 initialization
   //uItemTip := TItemTip.Create(Application);  // all listboxes share a single ItemTip window