Changeset 829 for cprs/trunk/CPRS-Lib


Ignore:
Timestamp:
Jul 7, 2010, 4:31:10 PM (14 years ago)
Author:
Kevin Toppenberg
Message:

Upgrade to version 27

Location:
cprs/trunk/CPRS-Lib
Files:
16 added
12 deleted
11 edited

Legend:

Unmodified
Added
Removed

  • cprs/trunk/CPRS-Lib/ORCtrls.pas

    r456 r829  
    77uses Windows, Messages, SysUtils, Classes, Graphics, Controls, StdCtrls, Forms,
    88     ComCtrls, Commctrl, Buttons, ExtCtrls, Grids, ImgList, Menus, CheckLst,
    9      Accessibility_TLB, Variants;
     9     Variants, VAClasses;
    1010
    1111const
    … …  
    2121
    2222type
    23 
    24   TORStaticText = class(TStaticText)
    25   private
    26      FOnEnter: TNotifyEvent;
    27      FOnExit: TNotifyEvent;
    28   published
    29      property OnEnter: TNotifyEvent read FOnEnter write FOnEnter;
    30      property OnExit: TNotifyEvent read FOnExit write FOnExit;
    31      procedure DoEnter; override;
    32      procedure DoExit; override;
     23  IORBlackColorModeCompatible = interface(IInterface)
     24  ['{3554985C-F524-45FA-8C27-4CDD8357DB08}']
     25    procedure SetBlackColorMode(Value: boolean);
    3326  end;
    3427
    … …  
    8174  end;
    8275
    83   TORListBox = class(TListBox)
     76  TORListBox = class(TListBox, IVADynamicProperty, IORBlackColorModeCompatible)
    8477  private
    8578    FFocusIndex: Integer;                        // item with focus when using navigation keys
    … …  
    127120    FMItems: TORStrings;                         // Used to save corresponding M strings ("the pieces")
    128121    FCaption: TStaticText;                       // Used to supply a title to IAccessible interface
    129     FAccessible: IAccessible;
    130122    FCaseChanged: boolean;                       // If true, the names are stored in the database as all caps, but loaded and displayed in mixed-case
    131123    FLookupPiece: integer;                       // If zero, list look-up comes from display string; if non-zero, indicates which piece of the item needs to be used for list lookup
    132     procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT;
     124    FIsPartOfComboBox: boolean;
     125    FBlackColorMode: boolean;
     126    FHideSelection: boolean;
    133127    procedure AdjustScrollBar;
    134128    procedure CreateScrollBar;
    … …  
    214208    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
    215209    function GetIndexFromY(YPos :integer) :integer;
     210    property isPartOfComboBox: boolean read FIsPartOfComboBox write FIsPartOfComboBox default False;
    216211    property HideSynonyms: boolean read FHideSynonyms write SetHideSynonyms default FALSE;
    217212    property SynonymChars: string read FSynonymChars write SetSynonymChars;
    … …  
    241236    property CheckedState[Index: Integer]: TCheckBoxState read GetCheckedState write SetCheckedState;
    242237    property MItems: TStrings read GetMItems write SetMItems;
    243     procedure MakeAccessible(Accessible: IAccessible);
    244238    function VerifyUnique(SelectIndex: Integer; iText: String): integer;
     239    procedure SetBlackColorMode(Value: boolean);
     240    function SupportsDynamicProperty(PropertyID: integer): boolean;
     241    function GetDynamicProperty(PropertyID: integer): string;
     242    property HideSelection: boolean read FHideSelection write FHideSelection;
    245243  published
    246244    property AllowGrayed: boolean read FAllowGrayed write FAllowGrayed default FALSE;
    … …  
    303301  end;
    304302
    305   TORComboBox = class(TWinControl)
     303  TORComboBox = class(TWinControl, IVADynamicProperty, IORBlackColorModeCompatible)
    306304  private
    307305    FItems: TStrings;                            // points to Items in FListBox
    … …  
    340338    FCharsNeedMatch: integer;                    // how many text need to be matched for auto selection
    341339    FUniqueAutoComplete: Boolean;                // If true only perform autocomplete for unique list items.
     340    FBlackColorMode: boolean;
     341    FDisableHints: boolean;                      // true if hints have been disabled because drop down window was opened
     342    FDropDownStatusChangedCount: integer;        // prevents multiple calls to disabling hint window
     343    procedure DropDownStatusChanged(opened: boolean);
     344    procedure ClearDropDownStatus;
    342345    function EditControl: TWinControl;
    343346    procedure AdjustSizeOfSelf;
    … …  
    440443    procedure SetLookupPiece(const Value: integer);
    441444    procedure SetUniqueAutoComplete(const Value: Boolean);
     445    procedure LoadComboBoxImage;
    442446  protected
    443447    procedure DropPanelBtnPressed(OKBtn, AutoClose: boolean);
    … …  
    452456  public
    453457    constructor Create(AOwner: TComponent); override;
     458    destructor Destroy; override;
    454459    function AddReference(const S: string; AReference: Variant): Integer;
    455460    procedure Clear;
    … …  
    458463    procedure InitLongList(S: string);
    459464    procedure InsertSeparator;
     465    procedure Invalidate; override;
    460466    procedure SetTextAutoComplete(TextToMatch : String);
    461467    function GetIEN(AnIndex: Integer): Int64;
    … …  
    466472    procedure InsertReference(Index: Integer; const S: string; AReference: Variant);
    467473    procedure SelectAll;
    468     function MakeAccessible( Accessible: IAccessible): TORListBox;
     474    procedure SetBlackColorMode(Value: boolean);
     475    function SupportsDynamicProperty(PropertyID: integer): boolean;
     476    function GetDynamicProperty(PropertyID: integer): string;
    469477    property DisplayText[Index: Integer]: string read GetDisplayText;
    470478    property DroppedDown: Boolean read FDroppedDown write SetDroppedDown;
    … …  
    648656
    649657
    650   TCaptionTreeView = class(TTreeView)
     658  TCaptionTreeView = class(TTreeView, IVADynamicProperty)
    651659  private
    652660    procedure SetCaption(const Value: string);
    … …  
    654662  protected
    655663    FCaptionComponent: TStaticText;
     664  public
     665    function SupportsDynamicProperty(PropertyID: integer): boolean;
     666    function GetDynamicProperty(PropertyID: integer): string;
    656667  published
    657668    property Align;
    … …  
    665676    FTag: integer;
    666677    FStringData: string;
    667     FAccessible: IAccessible;
    668678    FCaption: string;
    669     procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT;
    670679    function GetParent: TORTreeNode;
    671680    procedure SetCaption(const Value: string);
    … …  
    679688    function GetORTreeView: TORTreeView;
    680689  public
    681     procedure MakeAccessible(Accessible: IAccessible);
    682690    procedure SetPiece(PieceNum: Integer; const NewPiece: string);
    683691    procedure EnsureVisible;
    684     property Accessible: IAccessible read FAccessible write MakeAccessible;
    685692    property Bold: boolean read GetBold write SetBold;
    686693    property Tag: integer read FTag write FTag;
    … …  
    700707    FPiece: integer;
    701708    FOnAddition: TTVExpandedEvent;
    702     FAccessible: IAccessible;
    703709    FShortNodeCaptions: boolean;
    704710    FOnNodeCaptioning: TNodeCaptioningEvent;
    705     procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT;
    706711    procedure SetShortNodeCaptions(const Value: boolean);
    707712  protected
    … …  
    716721  public
    717722    constructor Create(AOwner: TComponent); override;
    718     procedure MakeAccessible(Accessible: IAccessible);
    719723    function FindPieceNode(Value: string;
    720724                           ParentDelim: Char = #0; StartNode: TTreeNode = nil): TORTreeNode; overload;
    … …  
    776780  TGrayedStyle = (gsNormal, gsQuestionMark, gsBlueQuestionMark);
    777781
    778   TORCheckBox = class(TCheckBox)
     782  TORCheckBox = class(TCheckBox, IORBlackColorModeCompatible)
    779783  private
    780784    FStringData: string;
    … …  
    793797    FAssociate: TControl;
    794798    FFocusOnBox: boolean;
     799    FBlackColorMode: boolean;
    795800    procedure SetFocusOnBox(value: boolean);
    796801    procedure CNMeasureItem    (var Message: TWMMeasureItem);   message CN_MEASUREITEM;
    … …  
    835840    destructor Destroy; override;
    836841    procedure AutoAdjustSize;
     842    procedure SetBlackColorMode(Value: boolean);
    837843    property SingleLine: boolean read FSingleLine;
    838844    property StringData: string read FStringData write FStringData;
    … …  
    899905  end;
    900906
    901   TCaptionListBox = class(TListBox)
     907  TCaptionListBox = class(TListBox, IVADynamicProperty)
    902908  private
    903909    FHoverItemPos: integer;
    904     FAccessible: IAccessible;
    905910    FRightClickSelect: boolean;                  // When true, a right click selects teh item
    906911    FHintOnItem: boolean;
    907912    procedure SetCaption(const Value: string);
    908913    function GetCaption: string;
    909     procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT;
    910914    procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;
    911915    procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE;
     916    procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
     917    procedure MoveFocusDown;
     918    procedure MoveFocusUp;
    912919  protected
    913920    FCaptionComponent: TStaticText;
    914921    procedure DoEnter; override;
    915922  public
    916     procedure MakeAccessible( Accessible: IAccessible);
     923    function SupportsDynamicProperty(PropertyID: integer): boolean;
     924    function GetDynamicProperty(PropertyID: integer): string;
    917925  published
    918926    property RightClickSelect: boolean read FRightClickSelect write FRightClickSelect default FALSE;
    … …  
    922930  end;
    923931
    924   TCaptionCheckListBox = class(TCheckListBox)
     932  TCaptionCheckListBox = class(TCheckListBox, IVADynamicProperty)
    925933  private
    926934    procedure SetCaption(const Value: string);
    … …  
    928936  protected
    929937    FCaptionComponent: TStaticText;
     938  public
     939    function SupportsDynamicProperty(PropertyID: integer): boolean;
     940    function GetDynamicProperty(PropertyID: integer): string;
    930941  published
    931942    property Caption: string read GetCaption write SetCaption;
    932943  end;
    933944
    934   TCaptionMemo = class(TMemo)
     945  TCaptionMemo = class(TMemo, IVADynamicProperty)
    935946  private
    936947    procedure SetCaption(const Value: string);
    … …  
    938949  protected
    939950    FCaptionComponent: TStaticText;
     951  public
     952    function SupportsDynamicProperty(PropertyID: integer): boolean;
     953    function GetDynamicProperty(PropertyID: integer): string;
    940954  published
    941955    property Caption: string read GetCaption write SetCaption;
    942956  end;
    943957
    944   TCaptionEdit = class(TEdit)
     958  TCaptionEdit = class(TEdit, IVADynamicProperty)
    945959  private
    946960    procedure SetCaption(const Value: string);
    … …  
    948962  protected
    949963    FCaptionComponent: TStaticText;
     964  public
     965    function SupportsDynamicProperty(PropertyID: integer): boolean;
     966    function GetDynamicProperty(PropertyID: integer): string;
    950967  published
    951968    property Align;
    … …  
    953970  end;
    954971
    955   TCaptionRichEdit = class(TRichEdit)
     972  TCaptionRichEdit = class(TRichEdit, IVADynamicProperty)
    956973  private
    957     FAccessible: IAccessible;
    958     procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT;
    959974  protected
    960975    FCaption: string;
    961976  public
    962     procedure MakeAccessible(Accessible: IAccessible);
     977    function SupportsDynamicProperty(PropertyID: integer): boolean;
     978    function GetDynamicProperty(PropertyID: integer): string;
    963979  published
    964980    property Align;
    … …  
    966982  end;
    967983
    968   TCaptionComboBox = class(TComboBox)
     984  TCaptionComboBox = class(TComboBox, IVADynamicProperty)
    969985  private
    970986    procedure SetCaption(const Value: string);
    … …  
    972988  protected
    973989    FCaptionComponent: TStaticText;
     990  public
     991    function SupportsDynamicProperty(PropertyID: integer): boolean;
     992    function GetDynamicProperty(PropertyID: integer): string;
    974993  published
    975994    property Caption: string read GetCaption write SetCaption;
    976995  end;
    977996
    978   TCaptionListView = class(TListView)
     997  TCaptionListView = class(TListView, IVADynamicProperty)
     998  public
     999    function SupportsDynamicProperty(PropertyID: integer): boolean;
     1000    function GetDynamicProperty(PropertyID: integer): string;
    9791001  published
    9801002    property Caption;
    9811003  end;
    9821004
    983   TCaptionStringGrid = class(TStringGrid)
     1005  TCaptionStringGrid = class(TStringGrid, IVADynamicProperty)
    9841006  private
    9851007    FJustToTab: boolean;
    9861008    FCaption: string;
    987     FAccessible: IAccessible;
    988     procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT;
    9891009  protected
    9901010    procedure KeyUp(var Key: Word; Shift: TShiftState); override;
    9911011  public
    992     procedure MakeAccessible( Accessible: IAccessible);
    9931012    procedure IndexToColRow( index: integer; var Col: integer; var Row: integer);
    9941013    function ColRowToIndex( Col: integer; Row: Integer): integer;
     1014    function SupportsDynamicProperty(PropertyID: integer): boolean;
     1015    function GetDynamicProperty(PropertyID: integer): string;
    9951016  published
    9961017    property Caption: string read FCaption write FCaption;
    … …  
    10151036
    10161037uses
    1017   uAccessAPI;
     1038  VAUtils;
    10181039 
    10191040const
    … …  
    14241445    'ORCB_RADIO_DISABLED_UNCHECKED', 'ORCB_RADIO_DISABLED_CHECKED');
    14251446
    1426 var
    1427   ORCBImages: array[TORCBImgIdx] of TBitMap;
    1428 
    1429 function GetORCBBitmap(Idx: TORCBImgIdx): TBitmap;
    1430 begin
    1431   if(not assigned(ORCBImages[Idx])) then
    1432   begin
    1433     ORCBImages[Idx] := TBitMap.Create;
    1434     ORCBImages[Idx].LoadFromResourceName(HInstance, CheckBoxImageResNames[Idx]);
    1435   end;
    1436   Result := ORCBImages[Idx];
     1447   BlackCheckBoxImageResNames: array[TORCBImgIdx] of PChar = (
     1448    'BLACK_ORLB_FLAT_UNCHECKED', 'BLACK_ORLB_FLAT_CHECKED', 'BLACK_ORLB_FLAT_GRAYED',
     1449    'BLACK_ORCB_QUESTIONMARK', 'BLACK_ORCB_BLUEQUESTIONMARK',
     1450    'BLACK_ORCB_DISABLED_UNCHECKED', 'BLACK_ORCB_DISABLED_CHECKED',
     1451    'BLACK_ORCB_DISABLED_GRAYED', 'BLACK_ORCB_DISABLED_QUESTIONMARK',
     1452    'BLACK_ORLB_FLAT_UNCHECKED', 'BLACK_ORLB_FLAT_CHECKED', 'BLACK_ORLB_FLAT_GRAYED',
     1453    'BLACK_ORCB_RADIO_UNCHECKED', 'BLACK_ORCB_RADIO_CHECKED',
     1454    'BLACK_ORCB_RADIO_DISABLED_UNCHECKED', 'BLACK_ORCB_RADIO_DISABLED_CHECKED');
     1455 
     1456var
     1457  ORCBImages: array[TORCBImgIdx, Boolean] of TBitMap;
     1458
     1459function GetORCBBitmap(Idx: TORCBImgIdx; BlackMode: boolean): TBitmap;
     1460var
     1461  ResName: string;
     1462begin
     1463  if(not assigned(ORCBImages[Idx, BlackMode])) then
     1464  begin
     1465    ORCBImages[Idx, BlackMode] := TBitMap.Create;
     1466    if BlackMode then
     1467      ResName := BlackCheckBoxImageResNames[Idx]
     1468    else
     1469      ResName := CheckBoxImageResNames[Idx];
     1470    ORCBImages[Idx, BlackMode].LoadFromResourceName(HInstance, ResName);
     1471  end;
     1472  Result := ORCBImages[Idx, BlackMode];
    14371473end;
    14381474
    … …  
    14401476var
    14411477  i: TORCBImgIdx;
     1478  mode: boolean;
    14421479
    14431480begin
    14441481  for i := low(TORCBImgIdx) to high(TORCBImgIdx) do
    14451482  begin
    1446     if(assigned(ORCBImages[i])) then
    1447       ORCBImages[i].Free;
    1448   end;
    1449 end;
    1450 
    1451 { TORStaticText }
    1452 
    1453 procedure TORStaticText.DoEnter;
    1454 begin
    1455   inherited DoEnter;
    1456   if Assigned(FOnEnter) then
    1457      FOnEnter(Self);
    1458 end;
    1459 
    1460 procedure TORStaticText.DoExit;
    1461 begin
    1462   inherited DoExit;
    1463   if Assigned(FOnExit) then
    1464      FOnExit(Self);
     1483    for Mode := false to true do
     1484    begin
     1485      if(assigned(ORCBImages[i, Mode])) then
     1486        ORCBImages[i, Mode].Free;
     1487    end;
     1488  end;
    14651489end;
    14661490
    … …  
    16581682  FCaseChanged := TRUE;
    16591683  FLookupPiece := 0;
     1684  FIsPartOfComboBox := False;
    16601685end;
    16611686
    … …  
    17681793    SetString(Result, Buf, Len);
    17691794  end;
     1795end;
     1796
     1797function TORListBox.GetDynamicProperty(PropertyID: integer): string;
     1798begin
     1799  if PropertyID = DynaPropAccesibilityCaption then
     1800    Result := GetCaption
     1801  else
     1802    Result := '';
    17701803end;
    17711804
    … …  
    20162049  case Message.CharCode of
    20172050    VK_LBUTTON, VK_RETURN, VK_SPACE:
    2018     if FocusIndex > -1 then
    2019     begin
    2020       if MultiSelect then
     2051    begin
     2052      if (FocusIndex < 0) and (CheckBoxes or MultiSelect) and (Count > 0) then // JNM - 508 compliance
     2053        SetFocusIndex(0);
     2054      if FocusIndex > -1 then
    20212055      begin
    2022         IsSelected := LongBool(Perform(LB_GETSEL, FocusIndex, 0));
    2023         Perform(LB_SETSEL, Longint(not IsSelected), FocusIndex);
    2024       end
    2025       else Perform(LB_SETCURSEL, FocusIndex, 0);
    2026       // Send WM_COMMAND here because LBN_SELCHANGE not triggered by LB_SETSEL
    2027       // and LBN_SELCHANGE is what eventually triggers the Click event.
    2028       // The LBN_SELCHANGE documentation implies we should send the control id, which is
    2029       // 32 bits long, in the high word of WPARAM (16 bits).  Since that won't work - we'll
    2030       // try sending the item index instead.
    2031       //PostMessage() not SendMessage() is Required here for checkboxes, SendMessage() doesn't
    2032       //Allow the Checkbox state on the control to be updated
    2033       if CheckBoxes then
    2034         PostMessage(Parent.Handle, WM_COMMAND, MAKELONG(FocusIndex, LBN_SELCHANGE), LPARAM(Handle))
    2035       else
    2036         SendMessage(Parent.Handle, WM_COMMAND, MAKELONG(FocusIndex, LBN_SELCHANGE), LPARAM(Handle));
     2056        if MultiSelect then
     2057        begin
     2058          IsSelected := LongBool(Perform(LB_GETSEL, FocusIndex, 0));
     2059          Perform(LB_SETSEL, Longint(not IsSelected), FocusIndex);
     2060        end
     2061        else Perform(LB_SETCURSEL, FocusIndex, 0);
     2062        // Send WM_COMMAND here because LBN_SELCHANGE not triggered by LB_SETSEL
     2063        // and LBN_SELCHANGE is what eventually triggers the Click event.
     2064        // The LBN_SELCHANGE documentation implies we should send the control id, which is
     2065        // 32 bits long, in the high word of WPARAM (16 bits).  Since that won't work - we'll
     2066        // try sending the item index instead.
     2067        //PostMessage() not SendMessage() is Required here for checkboxes, SendMessage() doesn't
     2068        //Allow the Checkbox state on the control to be updated
     2069        if CheckBoxes then
     2070          PostMessage(Parent.Handle, WM_COMMAND, MAKELONG(FocusIndex, LBN_SELCHANGE), LPARAM(Handle))
     2071        else
     2072          SendMessage(Parent.Handle, WM_COMMAND, MAKELONG(FocusIndex, LBN_SELCHANGE), LPARAM(Handle));
     2073      end;
    20372074    end;
    20382075    VK_PRIOR:          SetFocusIndex(FocusIndex - FLargeChange);
    … …  
    22362273  begin
    22372274    FLastItemIndex := ItemIndex;
     2275    if (not isPartOfComboBox) and (ItemIndex <> -1) then
     2276      SetFocusIndex(ItemIndex);
    22382277    if Assigned(FOnChange) then FOnChange(Self);
    22392278  end;
    … …  
    22482287{  if (Items.Count > 0) and (Not IsAMouseButtonDown()) and (ItemIndex = -1) then
    22492288    SetFocusIndex(TopIndex);//ItemIndex := TopIndex; }
     2289  if FHideSelection and (ItemIndex < 0) and (FFocusIndex >= 0) then
     2290    ItemIndex := FFocusIndex;
    22502291  inherited DoEnter;
    22512292end;
    22522293
    22532294procedure TORListBox.DoExit;
     2295var
     2296  SaveIndex: integer;
    22542297{ make sure item tip is hidden for this listbox when focus shifts to something else }
    22552298begin
     2299  if FHideSelection then
     2300  begin
     2301    SaveIndex := ItemIndex;
     2302    ItemIndex := -1;
     2303    FFocusIndex := SaveIndex;
     2304  end;
     2305
    22562306  uItemTip.Hide;
    22572307  FItemTipActive := False;
    … …  
    23212371procedure TORListBox.KeyPress(var Key: Char);
    23222372begin
     2373  {inherited KeyPress is changing the ' ' into #0, had to move conditional before inherited.}
     2374  if (Key = ' ') then begin
     2375    ToggleCheckBox(ItemIndex);
     2376    {The space bar causes the focus to jump to an item in the list that starts with
     2377     a space. Disable that function.}
     2378    Key := #0;
     2379  end;
    23232380  inherited;
    2324   if (Key = ' ') then ToggleCheckBox(ItemIndex);
    23252381end;
    23262382
    … …  
    24592515              begin
    24602516                if(FFlatCheckBoxes) then
    2461                   BMap := GetORCBBitmap(iiFlatUnChecked)
     2517                  BMap := GetORCBBitmap(iiFlatUnChecked, FBlackColorMode)
    24622518                else
    2463                   BMap := GetORCBBitmap(iiUnchecked);
     2519                  BMap := GetORCBBitmap(iiUnchecked, FBlackColorMode);
    24642520              end;
    24652521            cbChecked:
    24662522              begin
    24672523                if(FFlatCheckBoxes) then
    2468                   BMap := GetORCBBitmap(iiFlatChecked)
     2524                  BMap := GetORCBBitmap(iiFlatChecked, FBlackColorMode)
    24692525                else
    2470                   BMap := GetORCBBitmap(iiChecked);
     2526                  BMap := GetORCBBitmap(iiChecked, FBlackColorMode);
    24712527              end;
    24722528            else // cbGrayed:
    24732529              begin
    24742530                if(FFlatCheckBoxes) then
    2475                   BMap := GetORCBBitmap(iiFlatGrayed)
     2531                  BMap := GetORCBBitmap(iiFlatGrayed, FBlackColorMode)
    24762532                else
    2477                   BMap := GetORCBBitmap(iiGrayed);
     2533                  BMap := GetORCBBitmap(iiGrayed, FBlackColorMode);
    24782534              end;
    24792535          end;
    … …  
    24822538        begin
    24832539          if(FFlatCheckBoxes) then
    2484             BMap := GetORCBBitmap(iiFlatGrayed)
     2540            BMap := GetORCBBitmap(iiFlatGrayed, FBlackColorMode)
    24852541          else
    2486             BMap := GetORCBBitmap(iiGrayed);
     2542            BMap := GetORCBBitmap(iiGrayed, FBlackColorMode);
    24872543        end;
    24882544        TmpR := Rect;
    … …  
    25842640    end;
    25852641  end;                                              // -- special long list processing - end
     2642  if (Value = SFI_END) or (not (Value < Items.Count)) then Value := Items.Count - 1;
    25862643  if (Value = SFI_TOP) or (Value < 0) then Value := 0;
    2587   if (Value = SFI_END) or (not (Value < Items.Count)) then Value := Items.Count - 1;
    25882644  FFocusIndex := Value;
    2589   ItemIndex := Value;
     2645  if Focused or (not FHideSelection) then
     2646    ItemIndex := Value;
    25902647  if MultiSelect then Perform(LB_SETCARETINDEX, FFocusIndex, 0) // LPARAM=0, scrolls into view
    25912648  else
    … …  
    28502907end;
    28512908
     2909function TORListBox.SupportsDynamicProperty(PropertyID: integer): boolean;
     2910begin
     2911  Result := (PropertyID = DynaPropAccesibilityCaption);
     2912end;
     2913
    28522914procedure TORListBox.SetHideSynonyms(Value :boolean);
    28532915var
    … …  
    29302992  Strings: TStringList;
    29312993  i, Pos: Integer;
    2932   ItemRec: PItemRec;
     2994  ItemRec, ItemRec2: PItemRec;
    29332995  SaveListMode: Boolean;
    29342996  RealVerify: Boolean;
    … …  
    29603022      begin
    29613023        Pos := Items.AddObject(Strings[i], ItemRec^.UserObject);
    2962         References[Pos] := ItemRec^.Reference;
     3024        // CQ 11491 - Changing TabPositions, etc. was wiping out check box status.
     3025        FFromSelf := True;
     3026        ItemRec2 := PItemRec(SendMessage(Handle,LB_GETITEMDATA, Pos, 0));
     3027        FFromSelf := False;
     3028        if(assigned(ItemRec2)) then
     3029        begin
     3030          ItemRec2^.Reference := ItemRec^.Reference;
     3031          ItemRec2^.CheckedState := ItemRec^.CheckedState;
     3032        end;
    29633033      end;
    29643034    end;
    … …  
    35053575end;
    35063576
     3577procedure TORListBox.SetBlackColorMode(Value: boolean);
     3578begin
     3579  FBlackColorMode := Value;
     3580end;
     3581
    35073582procedure TORListBox.SetCaption(const Value: string);
    35083583begin
    … …  
    35273602end;
    35283603
    3529 procedure TORListBox.MakeAccessible(Accessible: IAccessible);
    3530 begin
    3531   if Assigned(FAccessible) and Assigned(Accessible) then
    3532     raise Exception.Create(Caption + ' List Box is already Accessible!')
    3533   else
    3534     FAccessible := Accessible;
    3535 end;
    3536 
    3537 procedure TORListBox.WMGetObject(var Message: TMessage);
    3538 begin
    3539   if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then
    3540     Message.Result := GetLResult(Message.wParam, FAccessible)
    3541   else
    3542     inherited;
     3604// In Delphi 2006, hint windows will cause the TORComboBox drop down list to
     3605// move behind a Stay on Top form.  Hints are also problematic with item tips in
     3606// the drop down list, so we disable them when ever a drop down list is open,
     3607// on all forms, not just stay on top forms.
     3608var
     3609  uDropPanelOpenCount: integer = 0;
     3610  uOldShowHintsSetting: boolean;
     3611
     3612procedure DropDownPanelOpened;
     3613begin
     3614  if uDropPanelOpenCount=0 then
     3615    uOldShowHintsSetting := Application.ShowHint;
     3616  Application.ShowHint := FALSE;
     3617  inc(uDropPanelOpenCount);
     3618end;
     3619
     3620procedure DropDownPanelClosed;
     3621begin
     3622  dec(uDropPanelOpenCount);
     3623  if uDropPanelOpenCount<=0 then
     3624  begin
     3625    uDropPanelOpenCount := 0;
     3626    if not Application.ShowHint then
     3627      Application.ShowHint := uOldShowHintsSetting
     3628  end;
    35433629end;
    35443630
    … …  
    36903776const
    36913777  ComboBoxImages: array[boolean] of string = ('BMP_CBODOWN_DISABLED', 'BMP_CBODOWN');
    3692  
     3778  BlackComboBoxImages: array[boolean] of string = ('BLACK_BMP_CBODOWN_DISABLED', 'BLACK_BMP_CBODOWN');
     3779
    36933780procedure TORComboEdit.CreateParams(var Params: TCreateParams);
    36943781{ sets a one line edit box to multiline style so the editing rectangle can be changed }
    … …  
    37403827  FCheckBoxEditColor := clBtnFace;
    37413828  FListBox := TORListBox.Create(Self);
     3829  FListBox.isPartOfComboBox := True;
    37423830  FListBox.Parent := Self;
    37433831  FListBox.TabStop := False;
    … …  
    38663954end;
    38673955
     3956procedure TORComboBox.DropDownStatusChanged(opened: boolean);
     3957begin
     3958  if opened then
     3959  begin
     3960    if not FDropPanel.Visible then
     3961    begin
     3962      if FDropDownStatusChangedCount = 0 then
     3963      begin
     3964        FDisableHints := TRUE;
     3965        DropDownPanelOpened;
     3966      end;
     3967      inc(FDropDownStatusChangedCount);
     3968    end;
     3969  end
     3970  else
     3971  begin
     3972    dec(FDropDownStatusChangedCount);
     3973    if FDropDownStatusChangedCount <= 0 then
     3974    begin
     3975      if FDisableHints then
     3976      begin
     3977        DropDownPanelClosed;
     3978        FDisableHints := FALSE;
     3979      end;
     3980      FDropDownStatusChangedCount := 0;
     3981    end;
     3982  end;
     3983end;
     3984
     3985procedure TORComboBox.ClearDropDownStatus;
     3986begin
     3987  FDropDownStatusChangedCount := 1;
     3988  DropDownStatusChanged(FALSE);
     3989end;
     3990
     3991destructor TORComboBox.Destroy;
     3992begin
     3993  ClearDropDownStatus;
     3994  inherited;
     3995end;
     3996
    38683997procedure TORComboBox.DoEnter;
    38693998{var
    … …  
    39024031  end;
    39034032  inherited DoExit;
     4033end;
     4034
     4035procedure TORComboBox.LoadComboBoxImage;
     4036var
     4037  imageName: string;
     4038begin
     4039  if assigned(FDropBtn) then
     4040  begin
     4041    if FBlackColorMode then
     4042      imageName := BlackComboBoxImages[inherited Enabled]
     4043    else
     4044      imageName := ComboBoxImages[inherited Enabled];
     4045    FDropBtn.Glyph.LoadFromResourceName(hInstance, imageName);
     4046  end;
    39044047end;
    39054048
    … …  
    40984241
    40994242procedure TORComboBox.FwdKeyPress(Sender: TObject; var Key: Char);
     4243var
     4244  KeyCode: integer;
    41004245{ prevents return from being used by editbox (otherwise sends a newline & text vanishes) }
    41014246begin
    4102   // may want to make the tab beep if tab key (#9) - can't tab until list raised
    4103   if (Key in [#9, #13]) or (FListBox.FCheckBoxes and (Key = #32)) then
    4104   begin
     4247  KeyCode := ord(Key);
     4248  if (KeyCode = VK_RETURN) and (Style = orcsDropDown) and DroppedDown then
     4249  begin
     4250    DroppedDown := FALSE;
    41054251    Key := #0;
    4106     Exit;
    4107   end;
    4108   if Assigned(FOnKeyPress) then FOnKeyPress(Self, Key);
     4252  end
     4253  else
     4254  begin
     4255    // may want to make the tab beep if tab key (#9) - can't tab until list raised
     4256    if (KeyCode = VK_RETURN) or (KeyCode = VK_TAB) or (FListBox.FCheckBoxes and (KeyCode = VK_SPACE)) then
     4257    begin
     4258      Key := #0;
     4259      Exit;
     4260    end;
     4261    if Assigned(FOnKeyPress) then FOnKeyPress(Self, Key);
     4262  end;
    41094263end;
    41104264
    … …  
    41684322      FCheckedState := FListBox.GetCheckedString;
    41694323    end;
     4324    DropDownStatusChanged(TRUE);
    41704325    FDropPanel.Visible := True;
    41714326    FDropPanel.BringToFront;
    … …  
    41784333    uItemTip.Hide;
    41794334    FDropPanel.Hide;
     4335    DropDownStatusChanged(FALSE);
    41804336    if(FListBox.FCheckBoxes) and (assigned(FOnChange)) and
    41814337      (FCheckedState <> FListBox.GetCheckedString) then
    … …  
    42654421    begin
    42664422      if FDropBtn <> nil then FDropBtn.Free;
    4267       if FDropPanel <> nil then FDropPanel.Free;
     4423      if FDropPanel <> nil then
     4424      begin
     4425        ClearDropDownStatus;
     4426        FDropPanel.Free;
     4427      end;
    42684428      FDropBtn := nil;
    42694429      FDropPanel := nil;
    … …  
    42804440      if(assigned(FEditPanel) and (csDesigning in ComponentState)) then
    42814441        FEditPanel.ControlStyle := FEditPanel.ControlStyle - [csAcceptsControls];
    4282       FDropBtn.Glyph.LoadFromResourceName(hInstance, ComboBoxImages[inherited Enabled]);
     4442      LoadComboBoxImage;
     4443//      FDropBtn.Glyph.LoadFromResourceName(hInstance, ComboBoxImages[inherited Enabled]);
    42834444      FDropBtn.OnMouseDown := DropButtonDown;
    42844445      FDropBtn.OnMouseUp := DropButtonUp;
    … …  
    42924453        FListBox.FParentCombo := Self;
    42934454        FListBox.Parent := FDropPanel;
     4455        ClearDropDownStatus;
    42944456        if FListBox.FScrollBar <> nil then FListBox.FScrollBar.Parent := FDropPanel;  // if long
    42954457      end else
    … …  
    43284490end;
    43294491
     4492function TORComboBox.SupportsDynamicProperty(PropertyID: integer): boolean;
     4493begin
     4494  Result := (PropertyID = DynaPropAccesibilityCaption);
     4495end;
     4496
    43304497// Since TORComboBox is composed of several controls (FEditBox, FListBox, FDropBtn), the
    43314498// following functions and procedures map public and published properties to their related
    … …  
    43734540end;
    43744541
     4542procedure TORComboBox.Invalidate;
     4543begin
     4544  inherited;
     4545  FEditBox.Invalidate;
     4546  FListBox.Invalidate;
     4547  if assigned(FEditPanel) then
     4548    FEditPanel.Invalidate;
     4549  if assigned(FDropBtn) then
     4550    FDropBtn.Invalidate;
     4551  if assigned(FDropPanel) then
     4552    FDropPanel.Invalidate;
     4553end;
     4554
    43754555function TORComboBox.GetAutoSelect: Boolean;
    43764556begin
    … …  
    43934573end;
    43944574
     4575function TORComboBox.GetDynamicProperty(PropertyID: integer): string;
     4576begin
     4577  if PropertyID = DynaPropAccesibilityCaption then
     4578    Result := GetCaption
     4579  else
     4580    Result := '';
     4581end;
     4582
    43954583function TORComboBox.GetItemHeight: Integer;
    43964584begin
    … …  
    45164704begin
    45174705  FEditBox.AutoSelect := Value;
     4706end;
     4707
     4708procedure TORComboBox.SetBlackColorMode(Value: boolean);
     4709begin
     4710  if FBlackColorMode <> Value then
     4711  begin
     4712    FBlackColorMode := Value;
     4713    FListBox.SetBlackColorMode(Value);
     4714    LoadComboBoxImage;
     4715  end;
    45184716end;
    45194717
    … …  
    47744972  if (inherited GetEnabled <> Value) then
    47754973  begin
     4974    DroppedDown := FALSE;
    47764975    inherited SetEnabled(Value);
    47774976    if assigned(FDropBtn) then
    4778       FDropBtn.Glyph.LoadFromResourceName(hInstance, ComboBoxImages[Value]);
     4977      LoadComboBoxImage;
     4978//      FDropBtn.Glyph.LoadFromResourceName(hInstance, ComboBoxImages[Value]);
    47794979  end;
    47804980end;
    … …  
    48375037begin
    48385038  result := FListBox.Caption;
    4839 end;
    4840 
    4841 function TORComboBox.MakeAccessible(Accessible: IAccessible): TORListBox;
    4842 begin
    4843   FListBox.MakeAccessible(Accessible);
    4844   result := FListBox;
    48455039end;
    48465040
    … …  
    52615455        ORCtrls.SetPiece(FStringData, FDelim, FPiece, Value);
    52625456    end;
    5263 end;
    5264 
    5265 procedure TORTreeNode.MakeAccessible(Accessible: IAccessible);
    5266 begin
    5267   if Assigned(FAccessible) and Assigned(Accessible) then
    5268     raise Exception.Create(Text + ' Tree Node is already Accessible!')
    5269   else
    5270   begin
    5271     FAccessible := Accessible;
    5272   end;
    5273 end;
    5274 
    5275 procedure TORTreeNode.WMGetObject(var Message: TMessage);
    5276 begin
    5277   if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then
    5278     Message.Result := GetLResult(Message.wParam, FAccessible)
    5279   else
    5280     inherited;
    52815457end;
    52825458
    … …  
    55225698  else
    55235699    Result := '';
    5524 end;
    5525 
    5526 procedure TORTreeView.MakeAccessible(Accessible: IAccessible);
    5527 begin
    5528   if Assigned(FAccessible) and Assigned(Accessible) then
    5529     raise Exception.Create(Text + ' Tree View is already Accessible!')
    5530   else
    5531   begin
    5532     FAccessible := Accessible;
    5533   end;
    5534 end;
    5535 
    5536 procedure TORTreeView.WMGetObject(var Message: TMessage);
    5537 begin
    5538   if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then
    5539     Message.Result := GetLResult(Message.wParam, FAccessible)
    5540   else
    5541     inherited;
    55425700end;
    55435701
    … …  
    59086066              end;
    59096067            end;
    5910             Bitmap := GetORCBBitmap(ImgIdx);
     6068            Bitmap := GetORCBBitmap(ImgIdx, FBlackColorMode);
    59116069          end
    59126070          else
    … …  
    60506208            R.Top:= FocusRect.Top
    60516209          else
     6210          begin
    60526211            R.Top:= ((ClientHeight - Bitmap.Height + 1) div 2) - 1;
    6053 
     6212            if R.Top < 0 then R.Top := 0           
     6213          end;
    60546214          Draw(R.Left, R.Top, Bitmap);
    60556215        end;
    … …  
    61456305end;
    61466306
     6307procedure TORCheckBox.SetBlackColorMode(Value: boolean);
     6308begin
     6309  if FBlackColorMode <> Value then
     6310  begin
     6311    FBlackColorMode := Value;
     6312    Invalidate;
     6313  end;
     6314end;
     6315
    61476316procedure TORCheckBox.AutoAdjustSize;
    61486317var
    … …  
    62766445    if DoCtrl then
    62776446      Ctrl.Enabled := Checked;
    6278     if(Ctrl is TWinControl) then
     6447
     6448    // added (csAcceptsControls in Ctrl.ControlStyle) below to prevent disabling of
     6449    // child sub controls, like the TBitBtn in the TORComboBox.  If the combo box is
     6450    // already disabled, we don't want to disable the button as well - when we do, we
     6451    // lose the disabled glyph that is stored on that button for the combo box.
     6452
     6453    if(Ctrl is TWinControl) and (csAcceptsControls in Ctrl.ControlStyle) then
    62796454    begin
    62806455      for i := 0 to TWinControl(Ctrl).ControlCount-1 do
    … …  
    65006675end;
    65016676
    6502 procedure TCaptionListBox.MakeAccessible(Accessible: IAccessible);
    6503 begin
    6504   if Assigned(FAccessible) and Assigned(Accessible) then
    6505     raise Exception.Create(Caption + ' List Box is already Accessible!')
     6677function TCaptionListBox.GetDynamicProperty(PropertyID: integer): string;
     6678begin
     6679  if PropertyID = DynaPropAccesibilityCaption then
     6680    Result := GetCaption
    65066681  else
    6507     FAccessible := Accessible;
     6682    Result := '';
     6683end;
     6684
     6685
     6686procedure TCaptionListBox.MoveFocusUp;
     6687begin
     6688  if ItemIndex > 0 then
     6689    Perform(LB_SETCARETINDEX, ItemIndex - 1, 0);
     6690end;
     6691
     6692procedure TCaptionListBox.MoveFocusDown;
     6693begin
     6694  if ItemIndex < (Items.Count-1) then
     6695    Perform(LB_SETCARETINDEX, ItemIndex + 1, 0);
    65086696end;
    65096697
    … …  
    65226710end;
    65236711
    6524 procedure TCaptionListBox.WMGetObject(var Message: TMessage);
    6525 begin
    6526   if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then
    6527     Message.Result := GetLResult(Message.wParam, FAccessible)
    6528   else
    6529     inherited;
     6712function TCaptionListBox.SupportsDynamicProperty(PropertyID: integer): boolean;
     6713begin
     6714  Result := (PropertyID = DynaPropAccesibilityCaption);
     6715end;
     6716
     6717procedure TCaptionListBox.WMKeyDown(var Message: TWMKeyDown);
     6718var
     6719  IsSelected: LongBool;
     6720begin
     6721  if Boolean(Hi(GetKeyState(VK_CONTROL))) and MultiSelect then
     6722    case Message.CharCode of
     6723      VK_SPACE:
     6724        begin
     6725          IsSelected := LongBool(Perform(LB_GETSEL, ItemIndex, 0));
     6726          Perform(LB_SETSEL, Longint(not IsSelected), ItemIndex);
     6727        end;
     6728      VK_LEFT, VK_UP: MoveFocusUp;
     6729      VK_RIGHT, VK_DOWN: MoveFocusDown;
     6730      else inherited;
     6731    end
     6732  else inherited;
    65306733end;
    65316734
    … …  
    65916794end;
    65926795
     6796function TCaptionCheckListBox.GetDynamicProperty(PropertyID: integer): string;
     6797begin
     6798  if PropertyID = DynaPropAccesibilityCaption then
     6799    Result := GetCaption
     6800  else
     6801    Result := '';
     6802end;
     6803
    65936804procedure TCaptionCheckListBox.SetCaption(const Value: string);
    65946805begin
    … …  
    66056816end;
    66066817
     6818function TCaptionCheckListBox.SupportsDynamicProperty(
     6819  PropertyID: integer): boolean;
     6820begin
     6821  Result := (PropertyID = DynaPropAccesibilityCaption);
     6822end;
     6823
    66076824{ TCaptionMemo }
    66086825
    … …  
    66136830  else
    66146831    result := FCaptionComponent.Caption;
     6832end;
     6833
     6834function TCaptionMemo.GetDynamicProperty(PropertyID: integer): string;
     6835begin
     6836  if PropertyID = DynaPropAccesibilityCaption then
     6837    Result := GetCaption
     6838  else
     6839    Result := '';
    66156840end;
    66166841
    … …  
    66296854end;
    66306855
     6856function TCaptionMemo.SupportsDynamicProperty(PropertyID: integer): boolean;
     6857begin
     6858  Result := (PropertyID = DynaPropAccesibilityCaption);
     6859end;
     6860
    66316861{ TCaptionEdit }
    66326862
    … …  
    66376867  else
    66386868    result := FCaptionComponent.Caption;
     6869end;
     6870
     6871function TCaptionEdit.GetDynamicProperty(PropertyID: integer): string;
     6872begin
     6873  if PropertyID = DynaPropAccesibilityCaption then
     6874    Result := GetCaption
     6875  else
     6876    Result := '';
    66396877end;
    66406878
    … …  
    66536891end;
    66546892
     6893function TCaptionEdit.SupportsDynamicProperty(PropertyID: integer): boolean;
     6894begin
     6895  Result := (PropertyID = DynaPropAccesibilityCaption);
     6896end;
     6897
    66556898{ TCaptionRichEdit }
    66566899
    6657 procedure TCaptionRichEdit.MakeAccessible(Accessible: IAccessible);
    6658 begin
    6659   if Assigned(FAccessible) and Assigned(Accessible) then
    6660     raise Exception.Create(Caption + ' Rich Edit is already Accessible!')
     6900function TCaptionRichEdit.GetDynamicProperty(PropertyID: integer): string;
     6901begin
     6902  if PropertyID = DynaPropAccesibilityCaption then
     6903    Result := FCaption
    66616904  else
    6662     FAccessible := Accessible;
    6663 end;
    6664 
    6665 procedure TCaptionRichEdit.WMGetObject(var Message: TMessage);
    6666 begin
    6667   if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then
    6668     Message.Result := GetLResult(Message.wParam, FAccessible)
     6905    Result := '';
     6906end;
     6907
     6908
     6909function TCaptionRichEdit.SupportsDynamicProperty(PropertyID: integer): boolean;
     6910begin
     6911  Result := (PropertyID = DynaPropAccesibilityCaption);
     6912end;
     6913
     6914{ TCaptionTreeView}
     6915
     6916function TCaptionTreeView.GetCaption: string;
     6917begin
     6918    result := inherited Caption;
     6919end;
     6920
     6921function TCaptionTreeView.GetDynamicProperty(PropertyID: integer): string;
     6922begin
     6923  if PropertyID = DynaPropAccesibilityCaption then
     6924    Result := GetCaption
    66696925  else
    6670     inherited;
    6671 end;
    6672 
    6673 { TCaptionTreeView}
    6674 
    6675 function TCaptionTreeView.GetCaption: string;
    6676 begin
    6677     result := inherited Caption;
     6926    Result := '';
    66786927end;
    66796928
    … …  
    66936942end;
    66946943
     6944function TCaptionTreeView.SupportsDynamicProperty(PropertyID: integer): boolean;
     6945begin
     6946  Result := (PropertyID = DynaPropAccesibilityCaption);
     6947end;
     6948
    66956949{ TCaptionComboBox }
    66966950
    … …  
    67016955  else
    67026956    result := FCaptionComponent.Caption;
     6957end;
     6958
     6959function TCaptionComboBox.GetDynamicProperty(PropertyID: integer): string;
     6960begin
     6961  if PropertyID = DynaPropAccesibilityCaption then
     6962    Result := GetCaption
     6963  else
     6964    Result := '';
    67036965end;
    67046966
    … …  
    67176979end;
    67186980
     6981function TCaptionComboBox.SupportsDynamicProperty(PropertyID: integer): boolean;
     6982begin
     6983  Result := (PropertyID = DynaPropAccesibilityCaption);
     6984end;
     6985
    67196986{ TORAlignSpeedButton }
    67206987
    … …  
    67427009  result := (ColCount - FixedCols) * (Row - FixedRows) +
    67437010      (Col - FixedCols) + 1;
     7011end;
     7012
     7013function TCaptionStringGrid.GetDynamicProperty(PropertyID: integer): string;
     7014begin
     7015  if PropertyID = DynaPropAccesibilityCaption then
     7016    Result := FCaption
     7017  else
     7018    Result := '';
    67447019end;
    67457020
    … …  
    67617036end;
    67627037
    6763 procedure TCaptionStringGrid.MakeAccessible(Accessible: IAccessible);
    6764 begin
    6765   if Assigned(FAccessible) and Assigned(Accessible) then
    6766     raise Exception.Create(Caption + 'String Grid is already Accessible!')
    6767   else
    6768     FAccessible := Accessible;
    6769 end;
    6770 
    6771 procedure TCaptionStringGrid.WMGetObject(var Message: TMessage);
    6772 begin
    6773   if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then
    6774     Message.Result := GetLResult(Message.wParam, FAccessible)
    6775   else
    6776     inherited;
     7038
     7039function TCaptionStringGrid.SupportsDynamicProperty(
     7040  PropertyID: integer): boolean;
     7041begin
     7042  Result := (PropertyID = DynaPropAccesibilityCaption);
    67777043end;
    67787044
    … …  
    68107076    if LongList then
    68117077    begin
    6812       //Currently Do nothing for LongLists
    6813      { if CompareText(iText, Copy(DisplayText[SelectIndex+1], 1, Length(iText))) = 0 then
    6814         Result := -1;}
     7078      //Implemented for CQ: 10092, PSI-04-057
     7079      //asume long lists are alphabetically ordered...
     7080      if CompareText(iText, Copy(DisplayText[SelectIndex+1], 1, Length(iText))) = 0 then
     7081        Result := -1;
    68157082    end
    68167083    else //Not a LongList
    … …  
    68367103end;
    68377104
     7105{ TCaptionListView }
     7106
     7107function TCaptionListView.GetDynamicProperty(PropertyID: integer): string;
     7108begin
     7109  if PropertyID = DynaPropAccesibilityCaption then
     7110    Result := Caption
     7111  else
     7112    Result := '';
     7113end;
     7114
     7115function TCaptionListView.SupportsDynamicProperty(PropertyID: integer): boolean;
     7116begin
     7117  Result := (PropertyID = DynaPropAccesibilityCaption);
     7118end;
     7119
    68387120initialization
    68397121  //uItemTip := TItemTip.Create(Application);  // all listboxes share a single ItemTip window

  • cprs/trunk/CPRS-Lib/ORCtrlsDsgn.pas

    r456 r829  
    153153begin
    154154  RegisterComponents('CPRS',
    155     [TORStaticText, TORListBox, TORComboBox, TORAutoPanel, TOROffsetLabel, TORAlignEdit,
     155    [TORListBox, TORComboBox, TORAutoPanel, TOROffsetLabel, TORAlignEdit,
    156156    TORAlignButton, TORAlignSpeedButton, TORTreeView, TORCheckBox, TORListView,
    157157    TKeyClickPanel, TKeyClickRadioGroup, TCaptionListBox, TCaptionCheckListBox,

  • cprs/trunk/CPRS-Lib/ORDtTm.dfm

    r456 r829  
    11object ORfrmDtTm: TORfrmDtTm
    2   Left = 550
    3   Top = 474
     2  Left = 586
     3  Top = 483
    44  BorderIcons = []
    55  BorderStyle = bsDialog

  • cprs/trunk/CPRS-Lib/ORDtTm.pas

    r456 r829  
    77uses
    88  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons,
    9   Grids, Calendar, ExtCtrls, ORFn, ORNet, ORDtTmCal, Mask, ComCtrls, ORCtrls;
     9  Grids, Calendar, ExtCtrls, ORFn, ORNet, ORDtTmCal, Mask, ComCtrls, OR2006Compatibility,
     10  ORCtrls, VAClasses;
    1011
    1112type
    12   TORfrmDtTm = class(TForm)
     13  TORfrmDtTm = class(Tfrm2006Compatibility)
    1314    bvlFrame: TBevel;
    1415    lblDate: TPanel;
    … …  
    5152    FNowPressed:  Boolean;
    5253    TimeIsRequired: Boolean;
     54  protected
     55    procedure Loaded; override;
    5356  end;
    5457
    … …  
    7578  end;
    7679
     80  // 508 class
     81  TORDateButton = class (TBitBtn);
     82
    7783  { TORDateBox }
    7884
    … …  
    8288  end;
    8389
    84   TORDateBox = class(TORDateEdit)
     90  TORDateBox = class(TORDateEdit, IVADynamicProperty, IORBlackColorModeCompatible)
    8591  private
    8692    FFMDateTime: TFMDateTime;
    8793    FDateOnly: Boolean;
    8894    FRequireTime: Boolean;
    89     FButton: TBitBtn;
     95    FButton: TORDateButton;
    9096    FFormat: string;
    9197    FTimeIsNow: Boolean;
    9298    FTemplateField: boolean;
    9399    FCaption: TStaticText;
     100    FBlackColorMode: boolean;
    94101    procedure ButtonClick(Sender: TObject);
    95102    function GetFMDateTime: TFMDateTime;
    … …  
    104111    procedure SetCaption(const Value: string);
    105112    function  GetCaption(): string;
    106                                                              
    107113  protected
    108114    procedure Change; override;
    109115    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
     116    property DateButton: TORDateButton read FButton;
    110117  public
    111118    constructor Create(AOwner: TComponent); override;
    112119    function IsValid: Boolean;
    113120    procedure Validate(var ErrMsg: string);
     121    procedure SetBlackColorMode(Value: boolean);
     122    function SupportsDynamicProperty(PropertyID: integer): boolean;
     123    function GetDynamicProperty(PropertyID: integer): string;
    114124    property Format: string read FFormat write FFormat;
    115125    property RelativeTime: string     read GetRelativeTime;
    … …  
    122132  end;
    123133
    124   TORDateCombo = class(TCustomPanel)
     134  // 508 classes
     135  TORDayCombo = class (TORComboBox);
     136  TORMonthCombo = class (TORComboBox);
     137  TORYearEdit = class(TMaskEdit)
     138  private
     139    FTemplateField: boolean;
     140    procedure SetTemplateField(const Value: boolean);
     141  protected
     142    property TemplateField: boolean read FTemplateField write SetTemplateField;
     143  end;
     144
     145  TORYearEditClass = Class of TORYearEdit;
     146
     147  TORDateCombo = class(TCustomPanel, IORBlackColorModeCompatible)
    125148  private
    126149    FYearChanging: boolean;
    127     FMonthCombo: TORComboBox;
    128     FDayCombo: TORComboBox;
    129     FYearEdit: TMaskEdit;
     150    FMonthCombo: TORMonthCombo;
     151    FDayCombo: TORDayCombo;
     152    FYearEdit: TORYearEdit;
    130153    FYearUD: TUpDown;
    131     FCalBtn: TSpeedButton;
     154    FCalBtn: TORDateButton;
    132155    FIncludeMonth: boolean;
    133156    FIncludeDay: boolean;
    … …  
    141164    FRebuilding: boolean;
    142165    FTemplateField: boolean;
     166    FBlackColorMode: boolean;
     167    FORYearEditClass: TORYearEditClass;
    143168    procedure SetIncludeBtn(const Value: boolean);
    144169    procedure SetIncludeDay(Value: boolean);
    … …  
    153178    procedure SetTemplateField(const Value: boolean);
    154179  protected
    155     procedure Rebuild;
     180    procedure Rebuild; virtual;
    156181    function InitDays(GetSize: boolean): integer;
    157182    function InitMonths(GetSize: boolean): integer;
    … …  
    169194    procedure Paint; override;
    170195    procedure Resized(Sender: TObject);
     196    property MonthCombo: TORMonthCombo read FMonthCombo;
     197    property DayCombo: TORDayCombo read FDayCombo;
     198    property YearEdit: TORYearEdit read FYearEdit;
     199    property YearUD: TUpDown read FYearUD;
     200    property CalBtn: TORDateButton read FCalBtn;
     201    property ORYearEditClass: TORYearEditClass read FORYearEditClass write FORYearEditClass;
    171202  public
    172203    constructor Create(AOwner: TComponent); override;
    173204    destructor Destroy; override;
    174205    function DateText: string;
     206    procedure SetBlackColorMode(Value: boolean);
    175207    property TemplateField: boolean read FTemplateField write SetTemplateField;
    176208    property FMDate: TFMDateTime read GetFMDate write SetFMDate;
    … …  
    280312end;
    281313
     314procedure LoadEllipsis(bitmap: TBitMap; BlackColorMode: boolean);
     315var
     316  ResName: string;
     317begin
     318  if BlackColorMode then
     319    ResName := 'BLACK_BMP_ELLIPSIS'
     320  else
     321    ResName := 'BMP_ELLIPSIS';
     322  bitmap.LoadFromResourceName(hInstance, ResName);
     323end;
     324
    282325{ TfrmORDtTm -------------------------------------------------------------------------------- }
    283326
    … …  
    351394procedure TORfrmDtTm.lstHourClick(Sender: TObject);
    352395begin
     396  if lstHour.ItemIndex = 0 then lstMinute.Items[0] := ':01  --' else lstMinute.Items[0] := ':00  --'; //<------ NEW CODE
    353397  if lstMinute.ItemIndex < 0 then lstMinute.ItemIndex := 0;
    354398  lstMinuteClick(Self);
    … …  
    374418
    375419  AMinute := lstMinute.ItemIndex * 5;
     420  if (AnHour = 0) and (AMinute = 0) then AMinute := 1;  //<-------------- NEW CODE
    376421  FFromSelf := True;
    377422  // if ampm time -
    … …  
    410455  begin
    411456    x := Trim(txtTime.Text);
    412     if (x='00:00') or (x='0:00') or (x='00:00:00') or (x='0:00:00') then x := '00:00:01';
     457    //if (x='00:00') or (x='0:00') or (x='00:00:00') or (x='0:00:00') then x := '00:00:01';
     458    if (x='00:00') or (x='0:00') or (x='00:00:00') or (x='0:00:00') then x := '00:01';  //<------- CHANGED CODE
    413459    StrToTime(x);
    414460    txtTime.Text := x;
    … …  
    420466begin
    421467  ModalResult := mrCancel;
     468end;
     469
     470procedure TORfrmDtTm.Loaded;
     471begin
     472  inherited Loaded;
     473  UpdateColorsFor508Compliance(Self);
    422474end;
    423475
    … …  
    515567begin
    516568  inherited Create(AOwner);
    517   FButton := TBitBtn.Create(Self);
     569  FButton := TORDateButton.Create(Self);
    518570  FButton.Parent := Self;
    519571  FButton.Width := 18;
    … …  
    521573  FButton.OnClick := ButtonClick;
    522574  FButton.TabStop := False;
    523   FButton.Glyph.LoadFromResourceName(hInstance, 'BMP_ELLIPSIS');
     575  FBlackColorMode := False;
     576  LoadEllipsis(FButton.Glyph, FALSE);
    524577  FButton.Visible := True;
    525578  FFormat := FMT_DATETIME;
    … …  
    567620end;
    568621
     622function TORDateBox.SupportsDynamicProperty(PropertyID: integer): boolean;
     623begin
     624  Result := (PropertyID = DynaPropAccesibilityCaption);
     625end;
     626
    569627procedure TORDateBox.ButtonClick(Sender: TObject);
    570628var
    … …  
    696754  if Length(x) = 0 then Result := True else Result := False;
    697755  if Length(Text) = 0 then Result := False;
     756end;
     757
     758procedure TORDateBox.SetBlackColorMode(Value: boolean);
     759begin
     760  if FBlackColorMode <> Value then
     761  begin
     762    FBlackColorMode := Value;
     763    LoadEllipsis(FButton.Glyph, FBlackColorMode);
     764  end;
    698765end;
    699766
    … …  
    717784end;
    718785
     786function TORDateBox.GetDynamicProperty(PropertyID: integer): string;
     787begin
     788  if PropertyID = DynaPropAccesibilityCaption then
     789    Result := GetCaption
     790  else
     791    Result := '';
     792end;
     793
    719794function IsLeapYear(AYear: Integer): Boolean;
    720795begin
    … …  
    745820  LastYear = 2200;
    746821
    747 type
    748   TORDateComboEdit = class(TMaskEdit)
    749   private
    750     FTemplateField: boolean;
    751     procedure SetTemplateField(const Value: boolean);
    752   protected
    753     property TemplateField: boolean read FTemplateField write SetTemplateField;
    754   end;
    755 
    756822{ TORDateComboEdit }
    757823
    758 procedure TORDateComboEdit.SetTemplateField(const Value: boolean);
     824procedure TORYearEdit.SetTemplateField(const Value: boolean);
    759825begin
    760826  if(FTemplateField <> Value) then
    … …  
    779845  FIncludeBtn := TRUE;
    780846  OnResize := Resized;
     847  FORYearEditClass := TORYearEdit;
    781848end;
    782849
    … …  
    868935          if(not assigned(FMonthCombo)) then
    869936          begin
    870             FMonthCombo := TORComboBox.Create(Self);
     937            FMonthCombo := TORMonthCombo.Create(Self);
    871938            FMonthCombo.Parent := Self;
    872939            FMonthCombo.Top := 0;
    … …  
    874941            FMonthCombo.Style := orcsDropDown;
    875942            FMonthCombo.DropDownCount := 13;
     943            FMonthCombo.ListItemsOnly := True;
    876944            FMonthCombo.OnChange := MonthChanged;
    877945          end;
    … …  
    888956            if(not assigned(FDayCombo)) then
    889957            begin
    890               FDayCombo := TORComboBox.Create(Self);
     958              FDayCombo := TORDayCombo.Create(Self);
    891959              FDayCombo.Parent := Self;
    892960              FDayCombo.Top := 0;
    893961              FDayCombo.Style := orcsDropDown;
     962              FDayCombo.ListItemsOnly := True;
    894963              FDayCombo.OnChange := DayChanged;
    895964              FDayCombo.DropDownCount := 11;
    … …  
    914983        if(not assigned(FYearEdit)) then
    915984        begin
    916           FYearEdit := TORDateComboEdit.Create(Self);
     985          FYearEdit := FORYearEditClass.Create(Self);
    917986          FYearEdit.Parent := Self;
    918987          FYearEdit.Top := 0;
    … …  
    922991        end;
    923992        FYearEdit.Font := Font;
    924         TORDateComboEdit(FYearEdit).TemplateField := FTemplateField;
     993        FYearEdit.TemplateField := FTemplateField;
    925994        Wide := GetYearSize;
    926995        FYearEdit.Width := Wide;
    … …  
    9471016          if(not assigned(FCalBtn)) then
    9481017          begin
    949             FCalBtn := TSpeedButton.Create(Self);
     1018            FCalBtn := TORDateButton.Create(Self);
     1019            FCalBtn.TabStop := FALSE;
    9501020            FCalBtn.Parent := Self;
    9511021            FCalBtn.Top := 0;
    952             FCalBtn.Glyph.LoadFromResourceName(hInstance, 'BMP_ELLIPSIS');
     1022            LoadEllipsis(FCalBtn.Glyph, FBlackColorMode);
    9531023            FCalBtn.OnClick := BtnClicked;
    9541024          end;
    … …  
    9731043      FRebuilding := FALSE;
    9741044    end;
     1045  end;
     1046end;
     1047
     1048procedure TORDateCombo.SetBlackColorMode(Value: boolean);
     1049begin
     1050  if FBlackColorMode <> Value then
     1051  begin
     1052    FBlackColorMode := Value;
     1053    if assigned(FCalBtn) then   
     1054      LoadEllipsis(FCalBtn.Glyph, FBlackColorMode);
    9751055  end;
    9761056end;

  • cprs/trunk/CPRS-Lib/ORDtTmRng.dfm

    r456 r829  
    1818    Left = 8
    1919    Top = 44
    20     Width = 53
     20    Width = 52
    2121    Height = 13
    2222    Caption = 'Begin Date'
    … …  
    2525    Left = 145
    2626    Top = 44
    27     Width = 45
     27    Width = 44
    2828    Height = 13
    2929    Caption = 'End Date'

  • cprs/trunk/CPRS-Lib/ORDtTmRng.pas

    r456 r829  
    55uses
    66  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
    7   StdCtrls, ORFn, ORDtTm;
     7  StdCtrls, ORFn, OR2006Compatibility, ORDtTm;
    88
    99type
    10   TORfrmDateRange = class(TForm)
     10  TORfrmDateRange = class(Tfrm2006Compatibility)
    1111    lblStart: TLabel;
    1212    lblStop: TLabel;
    … …  
    2121    FCalStart: TORDateBox;
    2222    FCalStop:  TORDateBox;
     23  protected
     24    procedure Loaded; override;
    2325  end;
    2426
    … …  
    217219  FCalStop.TabOrder := 1;
    218220  ResizeAnchoredFormToFont(self);
     221  UpdateColorsFor508Compliance(self);
    219222end;
    220223
    … …  
    225228end;
    226229
     230procedure TORfrmDateRange.Loaded;
     231begin
     232  inherited Loaded;
     233  UpdateColorsFor508Compliance(Self);
     234end;
     235
    227236end.

  • cprs/trunk/CPRS-Lib/ORFn.pas

    r456 r829  
    66
    77uses SysUtils, Windows, Messages, Classes, Controls, StdCtrls, ExtCtrls, ComCtrls, Forms,
    8      Graphics, Menus, RichEdit;
     8     Graphics, Menus, RichEdit, Buttons;
    99
    1010const
    … …  
    1313  BOOLCHAR: array[Boolean] of Char = ('0', '1');
    1414  UM_STATUSTEXT = (WM_USER + 302);               // used to send update status msg to main form
    15   COLOR_CREAM   = $F0FBFF;
     15
     16var
     17  ScrollBarHeight: integer = 0;
    1618
    1719type
    … …  
    6668function DelimCount(const Str, Delim: string): integer;
    6769procedure QuickCopy(AFrom, ATo: TObject);
     70procedure QuickAdd(AFrom, ATo: TObject);
     71procedure FastAssign(source, destination: TStrings);
     72procedure FastAddStrings(source, destination: TStrings);
    6873function ValidFileName(const InitialFileName: string): string;
    6974
    … …  
    8489procedure ResizeFormToFont(AForm: TForm);
    8590procedure ResizeAnchoredFormToFont( AForm: TForm);
     91procedure AdjustForWindowsXPStyleTitleBar(AForm: TForm);
    8692function ResizeWidth( OldFont: TFont; NewFont: TFont; OldWidth: integer): integer;
    8793function ResizeHeight( OldFont: TFont; NewFont: TFont; OldHeight: integer): integer;
    … …  
    96102function PopupComponent(Sender: TObject; PopupMenu: TPopupMenu): TComponent;
    97103procedure ReformatMemoParagraph(AMemo: TCustomMemo);
    98 function ReadOnlyColor: TColor;
     104
     105function BlackColorScheme: Boolean;
     106function NormalColorScheme: Boolean;
     107function Get508CompliantColor(Color: TColor): TColor;
     108procedure UpdateColorsFor508Compliance(control: TControl; InputEditControl: boolean = FALSE);
     109procedure UpdateReadOnlyColorScheme(Control: TControl; ReadOnly: boolean);
    99110
    100111{ ListBox Grid functions }
    … …  
    116127function TabIsPressed : Boolean;
    117128function ShiftTabIsPressed : Boolean;
     129function EnterIsPressed : Boolean;
    118130
    119131implementation  // ---------------------------------------------------------------------------
    120132
    121133uses
    122   ORCtrls, Grids, Chart, CheckLst;
     134  ORCtrls, Grids, Chart, CheckLst, VAUtils;
    123135
    124136const
    … …  
    606618function Piece(const S: string; Delim: char; PieceNum: Integer): string;
    607619{ returns the Nth piece (PieceNum) of a string delimited by Delim }
    608 var
    609   i: Integer;
    610   Strt, Next: PChar;
    611 begin
    612   i := 1;
    613   Strt := PChar(S);
    614   Next := StrScan(Strt, Delim);
    615   while (i < PieceNum) and (Next <> nil) do
    616   begin
    617     Inc(i);
    618     Strt := Next + 1;
    619     Next := StrScan(Strt, Delim);
    620   end;
    621   if Next = nil then Next := StrEnd(Strt);
    622   if i < PieceNum then Result := '' else SetString(Result, Strt, Next - Strt);
     620begin
     621  Result := VAUtils.Piece(S, Delim, PieceNum);
    623622end;
    624623
    625624function Pieces(const S: string; Delim: char; FirstNum, LastNum: Integer): string;
    626 { returns several contiguous pieces }
    627 var
    628   PieceNum: Integer;
    629 begin
    630   Result := '';
    631   for PieceNum := FirstNum to LastNum do Result := Result + Piece(S, Delim, PieceNum) + Delim;
    632   if Length(Result) > 0 then Delete(Result, Length(Result), 1);
     625begin
     626  Result := VAUtils.Pieces(S, Delim, FirstNum, LastNum);
    633627end;
    634628
    … …  
    779773    if obj is TListBox then
    780774      str[idx] := TListBox(obj).Items
     775    else
     776    if obj is TORComboBox then
     777      str[idx] := TORComboBox(obj).Items
     778    else
     779    if obj is TComboBox then
     780      str[idx] := TComboBox(obj).Items
    781781    else
    782782    if obj is TRichEdit then
    … …  
    815815  if fix[0] then TRichEdit(AFrom).PlainText := FALSE;
    816816  if fix[1] then TRichEdit(ATo).PlainText := FALSE;
     817  if ATo is TRichEdit then
     818    TRichEdit(ATo).SelStart := Length(TRichEdit(ATo).Lines.Text); //CQ: 16461
     819end;
     820
     821type
     822  QuickAddError = class(Exception);
     823
     824procedure QuickAdd(AFrom, ATo: TObject);
     825var
     826  ms: TMemoryStream;
     827  idx: integer;
     828  str: array[0..1] of TStrings;
     829  fix: array[0..1] of boolean;
     830
     831  procedure GetStrings(obj: TObject);
     832  begin
     833    if (CompareText(obj.ClassName, 'TRichEditStrings') = 0) then
     834      raise QuickCopyError.Create('You must pass the TRichEdit object into QuickAdd, NOT it''s Lines property.');
     835    if obj is TStrings then
     836      str[idx] := TStrings(obj)
     837    else
     838    if obj is TMemo then
     839      str[idx] := TMemo(obj).Lines
     840    else
     841    if obj is TORListBox then
     842      str[idx] := TORListBox(obj).Items
     843    else
     844    if obj is TListBox then
     845      str[idx] := TListBox(obj).Items
     846    else
     847    if obj is TORComboBox then
     848      str[idx] := TORComboBox(obj).Items
     849    else
     850    if obj is TComboBox then
     851      str[idx] := TComboBox(obj).Items
     852    else
     853    if obj is TRichEdit then
     854    begin
     855      with TRichEdit(obj) do
     856      begin
     857        str[idx] := Lines;
     858        if not PlainText then
     859        begin
     860          fix[idx] := TRUE;
     861          PlainText := TRUE;
     862        end;
     863      end;
     864    end
     865    else
     866      raise QuickAddError.Create('Unsupported object type (' + obj.ClassName +
     867                                  ') passed into QuickAdd.');
     868    inc(idx);
     869  end;
     870
     871
     872begin
     873  fix[0] := FALSE;
     874  fix[1] := FALSE;
     875  idx := 0;
     876  GetStrings(AFrom);
     877  GetStrings(ATo);
     878  ms := TMemoryStream.Create;
     879  try
     880    str[1].SaveToStream(ms);
     881    ms.Seek(0, soFromEnd);
     882    str[0].SaveToStream(ms);
     883    ms.Seek(0, soFromBeginning);
     884    str[1].Clear;
     885    str[1].LoadFromStream(ms);
     886  finally
     887    ms.Free;
     888  end;
     889  if fix[0] then TRichEdit(AFrom).PlainText := FALSE;
     890  if fix[1] then TRichEdit(ATo).PlainText := FALSE;
     891end;
     892
     893procedure FastAssign(source, destination: TStrings);
     894// do not use this with RichEdit Lines unless source is RichEdit with PlainText
     895var
     896  ms: TMemoryStream;
     897begin
     898  destination.Clear;
     899  if (source is TStringList) and (destination is TStringList) then
     900    destination.Assign(source)
     901  else
     902  if (CompareText(source.ClassName, 'TRichEditStrings') = 0) then
     903    destination.Assign(source)
     904  else
     905  begin
     906    ms := TMemoryStream.Create;
     907    try
     908      source.SaveToStream(ms);
     909      ms.Seek(0, soFromBeginning);
     910      destination.LoadFromStream(ms);
     911    finally
     912      ms.Free;
     913    end;
     914  end;
     915end;
     916
     917procedure FastAddStrings(source, destination: TStrings);
     918// do not use this with RichEdit Lines unless source and destination are RichEdit with PlainText
     919var
     920  ms: TMemoryStream;
     921begin
     922  if (source is TStringList) and (destination is TStringList) then
     923    destination.AddStrings(source)
     924  else
     925  begin
     926    ms := TMemoryStream.Create;
     927    try
     928      destination.SaveToStream(ms);
     929      ms.Seek(0, soFromEnd);
     930      source.SaveToStream(ms);
     931      ms.Seek(0, soFromBeginning);
     932      destination.Clear;
     933      destination.LoadFromStream(ms);
     934    finally
     935      ms.Free;
     936    end;
     937  end;
    817938end;
    818939
    … …  
    861982    end; {for i}
    862983    AList.Clear;
    863     AList.Assign(NewList);
     984    FastAssign(NewList, AList);
    864985  finally
    865986    NewList.Free;
    … …  
    12481369end;
    12491370
     1371var
     1372  AlignList, AnchorList: TStringList;
     1373
     1374function AnchorsToStr(Control: TControl): string;
     1375var
     1376  j: TAnchorKind;
     1377
     1378begin
     1379  Result := '';
     1380  for j := low(TAnchorKind) to high(TAnchorKind) do
     1381    if j in Control.Anchors then
     1382      Result := result + '1'
     1383    else
     1384      Result := result + '0'
     1385end;
     1386
     1387function StrToAnchors(i: integer): TAnchors;
     1388var
     1389  j: TAnchorKind;
     1390  value: string;
     1391  idx : integer;
     1392begin
     1393  Result := [];
     1394  value := AnchorList[i];
     1395  idx := 1;
     1396  for j := low(TAnchorKind) to high(TAnchorKind) do
     1397  begin
     1398    if copy(value,idx,1) = '1' then
     1399      include(Result, j);
     1400    inc(idx);
     1401  end;
     1402end;
     1403
     1404procedure SuspendAlign(AForm: TForm);
     1405var
     1406  i: integer;
     1407  control: TControl;
     1408begin
     1409  AForm.DisableAlign;
     1410  AlignList.Clear;
     1411  AnchorList.Clear;
     1412  for i := 0 to AForm.ControlCount-1 do
     1413  begin
     1414    control := AForm.Controls[i];
     1415    AlignList.Add(IntToStr(ord(control.align)));
     1416    control.Align := alNone;
     1417    AnchorList.Add(AnchorsToStr(control));
     1418    control.Anchors := [];
     1419  end;
     1420end;
     1421
     1422procedure RestoreAlign(AForm: TForm);
     1423var
     1424  i: integer;
     1425  control: TControl;
     1426begin
     1427  try
     1428    for i := 0 to AForm.ControlCount-1 do
     1429    begin
     1430      control := AForm.Controls[i];
     1431      control.Align := TAlign(StrToIntDef(AlignList[i],0));
     1432      control.Anchors := StrToAnchors(i);
     1433    end;
     1434    AlignList.Clear;
     1435    AnchorList.Clear;
     1436  finally
     1437    AForm.EnableAlign;
     1438  end;
     1439end;
     1440
    12501441procedure ResizeFormToFont(AForm: TForm);
    12511442var
    12521443  Rect: TRect;
    1253 begin
     1444  OldResize: TNotifyEvent;
     1445begin
     1446// CQ# 11481 apply size changes to form all at once, instead of piece by piece.  Otherwise,
     1447// multiple calls to fAutoSz.FormResize, even if the form has not resized, can distort
     1448// the controls beyond the size of the form.
    12541449  with AForm do begin
    1255     ClientWidth := ResizeWidth( Font, MainFont, ClientWidth);
    1256     ClientHeight := ResizeHeight( Font, MainFont, ClientHeight);
    1257     HorzScrollBar.Range := ResizeWidth( Font, MainFont, HorzScrollBar.Range);
    1258     VertScrollBar.Range := ResizeHeight( Font, MainFont, VertScrollBar.Range);
    1259     Rect := BoundsRect;
    1260     ForceInsideWorkArea(Rect);
    1261     BoundsRect := Rect;
    1262     ResizeFontsInDescendants( Font, MainFont, AForm);
    1263     //Important: We are using the font to calculate everything, so don't
    1264     //change font until now.
    1265     Font.Size := MainFont.Size;
     1450    OldResize := AForm.OnResize;
     1451    AForm.OnResize := nil;
     1452    try
     1453      SuspendAlign(AForm);
     1454      try
     1455        HorzScrollBar.Range := ResizeWidth( Font, MainFont, HorzScrollBar.Range);
     1456        VertScrollBar.Range := ResizeHeight( Font, MainFont, VertScrollBar.Range);
     1457        ClientWidth := ResizeWidth( Font, MainFont, ClientWidth);
     1458        ClientHeight := ResizeHeight( Font, MainFont, ClientHeight);
     1459        Rect := BoundsRect;
     1460        ForceInsideWorkArea(Rect);
     1461        BoundsRect := Rect;
     1462      finally
     1463        RestoreAlign(AForm);
     1464      end;
     1465      ResizeFontsInDescendants( Font, MainFont, AForm);
     1466      //Important: We are using the font to calculate everything, so don't
     1467      //change font until now.
     1468      Font.Size := MainFont.Size;
     1469    finally
     1470      if(Assigned(OldResize)) then
     1471      begin
     1472        AForm.OnResize := OldResize;
     1473        OldResize(AForm);
     1474      end;
     1475    end;
    12661476  end;
    12671477end;
    … …  
    12701480var
    12711481  Rect: TRect;
     1482  OldResize: TNotifyEvent;
     1483
    12721484begin
    12731485  with AForm do begin
    1274     ClientWidth  := ResizeWidth( Font, MainFont, ClientWidth);
    1275     ClientHeight := ResizeHeight( Font, MainFont, ClientHeight);
    1276     HorzScrollBar.Range := ResizeWidth( Font, MainFont, HorzScrollBar.Range);
    1277     VertScrollBar.Range := ResizeHeight( Font, MainFont, VertScrollBar.Range);
    1278     Rect := BoundsRect;
    1279     ForceInsideWorkArea(Rect);
    1280     BoundsRect := Rect;
    1281     ResizeDescendants( Font, MainFont, AForm);
    1282     ResizeFontsInDescendants( Font, MainFont, AForm);
    1283     //Important: We are using the font to calculate everything, so don't
    1284     //change font until now.
    1285     Font.Size := MainFont.Size;
     1486  // CQ# 11481 - see ResizeFormToFont
     1487    OldResize := AForm.OnResize;
     1488    AForm.OnResize := nil;
     1489    try
     1490      HorzScrollBar.Range := ResizeWidth( Font, MainFont, HorzScrollBar.Range);
     1491      VertScrollBar.Range := ResizeHeight( Font, MainFont, VertScrollBar.Range);
     1492      ClientWidth  := ResizeWidth( Font, MainFont, ClientWidth);
     1493      ClientHeight := ResizeHeight( Font, MainFont, ClientHeight);
     1494      Rect := BoundsRect;
     1495      ForceInsideWorkArea(Rect);
     1496      BoundsRect := Rect;
     1497      ResizeDescendants( Font, MainFont, AForm);
     1498      ResizeFontsInDescendants( Font, MainFont, AForm);
     1499      //Important: We are using the font to calculate everything, so don't
     1500      //change font until now.
     1501      Font.Size := MainFont.Size;
     1502    finally
     1503      if(Assigned(OldResize)) then
     1504      begin
     1505        AForm.OnResize := OldResize;
     1506        OldResize(AForm);
     1507      end;
     1508    end;
     1509  end;
     1510end;
     1511
     1512// CQ 11485 - Adjusts all forms  - adds additional height to the form to
     1513// adjust for Windows XP style title bars, and for large fonts in title bar
     1514procedure AdjustForWindowsXPStyleTitleBar(AForm: TForm);
     1515const
     1516  DEFAULT_CAPTION_HEIGHT = 19;
     1517  DEFAULT_MENU_HEIGHT = 19;
     1518
     1519var
     1520  dxsb, dysb, dy, menuDY: integer;
     1521
     1522begin
     1523// Call GetSystemMetrics each time because values can change between calls
     1524  dy := GetSystemMetrics(SM_CYCAPTION) - DEFAULT_CAPTION_HEIGHT;
     1525  if (AForm.Menu <> nil) then
     1526  begin
     1527    menuDY := GetSystemMetrics(SM_CYMENU) - DEFAULT_MENU_HEIGHT;
     1528    inc(dy, menuDY);
     1529  end;
     1530  if dy <> 0 then
     1531  begin
     1532    SuspendAlign(AForm);
     1533    try
     1534    // Assitional adjustment to allow scroll bars to dissappear
     1535      dxsb := GetSystemMetrics(SM_CXVSCROLL);
     1536      dysb := GetSystemMetrics(SM_CYHSCROLL);
     1537      AForm.Height := AForm.Height + dy + dysb;
     1538      AForm.Width := AForm.Width + dxsb;
     1539      AForm.Height := AForm.Height - dysb;
     1540      AForm.Width := AForm.Width - dxsb;
     1541    finally
     1542      RestoreAlign(AForm);
     1543    end;
    12861544  end;
    12871545end;
    … …  
    13291587begin
    13301588  DC := GetDC(0);
    1331   SaveFont := SelectObject(DC, AFontHandle);
    1332   GetTextExtentPoint32(DC, PChar(x), Length(x), TextSize);
    1333   Result := TextSize.cx;
    1334   SelectObject(DC, SaveFont);
    1335   ReleaseDC(0, DC);
     1589  try
     1590    SaveFont := SelectObject(DC, AFontHandle);
     1591    try
     1592      GetTextExtentPoint32(DC, PChar(x), Length(x), TextSize);
     1593      Result := TextSize.cx;
     1594    finally
     1595      SelectObject(DC, SaveFont);
     1596    end;
     1597  finally
     1598    ReleaseDC(0, DC);
     1599  end;
    13361600end;
    13371601
    … …  
    13441608begin
    13451609  DC := GetDC(0);
    1346   SaveFont := SelectObject(DC, AFontHandle);
    1347   GetTextExtentPoint32(DC, PChar(x), Length(x), TextSize);
    1348   Result := TextSize.cy;
    1349   SelectObject(DC, SaveFont);
    1350   ReleaseDC(0, DC);
     1610  try
     1611    SaveFont := SelectObject(DC, AFontHandle);
     1612    try
     1613      GetTextExtentPoint32(DC, PChar(x), Length(x), TextSize);
     1614      Result := TextSize.cy;
     1615    finally
     1616      SelectObject(DC, SaveFont);
     1617    end;
     1618  finally
     1619    ReleaseDC(0, DC);
     1620  end;
     1621  if Result > 255 then // CQ 11493
     1622    Result := 255; // This is maximum allowed by a Windows
    13511623end;
    13521624
    … …  
    13931665    end;
    13941666  end;
     1667  if Result > 255 then // CQ 11492
     1668    Result := 255; // This is maximum allowed by a Windows
    13951669end;
    13961670
    … …  
    14711745
    14721746var
    1473   uReadOnlyColor: TColor;
    1474   uHaveReadOnlyColor: boolean = FALSE;
    1475 
    1476 function ReadOnlyColor: TColor;
    1477 begin
    1478   if not uHaveReadOnlyColor then
    1479   begin
    1480     uHaveReadOnlyColor := TRUE;
    1481     if ColorToRGB(clWindow) = ColorToRGB(clWhite) then
    1482       uReadOnlyColor := $00F0FBFF
     1747  uNormalColorScheme: boolean = false;
     1748  uBlackColorScheme: boolean = false;
     1749  uWhiteColorScheme: boolean = false;
     1750  uMaroonColorWhenBlack: TColor = clMaroon;
     1751  uCheckColorScheme: boolean = true;
     1752  PURE_BLACK: longint = 0;
     1753
     1754const
     1755  uBorderlessWindowColorWhenBlack: TColor = clNavy;
     1756
     1757
     1758procedure CheckColorScheme;
     1759begin
     1760  if uCheckColorScheme then
     1761  begin
     1762    uNormalColorScheme :=
     1763      ((ColorToRGB(clWindow)      = ColorToRGB(clWhite)) and
     1764       (ColorToRGB(clWindowText)  = ColorToRGB(clBlack)) and
     1765       (ColorToRGB(clInfoText)    = ColorToRGB(clBlack)) and
     1766       (ColorToRGB(clInfoBk)     <> ColorToRGB(clWhite)));
     1767
     1768    uBlackColorScheme := ((ColorToRGB(clBtnFace) = ColorToRGB(clBlack)) and
     1769                          (ColorToRGB(clWindow) = ColorToRGB(clBlack)));
     1770    uWhiteColorScheme := ((ColorToRGB(clBtnFace) = ColorToRGB(clWhite)) and
     1771                          (ColorToRGB(clWindow) = ColorToRGB(clWhite)));
     1772
     1773    if uBlackColorScheme then
     1774    begin
     1775      if(ColorToRGB(clGrayText) = ColorToRGB(clWindowText)) then
     1776        uMaroonColorWhenBlack := clHighlightText
     1777      else
     1778        uMaroonColorWhenBlack := clGrayText;
     1779    end;
     1780
     1781    uCheckColorScheme := FALSE;
     1782  end;
     1783end;
     1784
     1785function BlackColorScheme: Boolean;
     1786begin
     1787  if uCheckColorScheme then CheckColorScheme;
     1788  Result := uBlackColorScheme;
     1789end;
     1790
     1791function NormalColorScheme: Boolean;
     1792begin
     1793  if uCheckColorScheme then CheckColorScheme;
     1794  Result := uNormalColorScheme;
     1795end;
     1796
     1797function Get508CompliantColor(Color: TColor): TColor;
     1798begin
     1799  Result := Color;
     1800  if NormalColorScheme then exit;
     1801
     1802  case Color of
     1803    clCream:    Result := clInfoBk;
     1804    clBlack:    Result := clWindowText;
     1805    clWhite:    Result := clWindow;
     1806  end;
     1807
     1808  if uBlackColorScheme then
     1809  begin
     1810    case Color of
     1811      clBlue:     Result := clAqua;
     1812      clMaroon:   Result := uMaroonColorWhenBlack;
     1813  //    clRed:      Result := clFuchsia;
     1814    end;
     1815  end;
     1816
     1817  if uWhiteColorScheme then
     1818  begin
     1819    case Color of
     1820      clGrayText: Result := clGray;
     1821    end;
     1822  end;
     1823end;
     1824
     1825type
     1826  TExposedControl = class(TControl)
     1827  public
     1828    property Color;
     1829    property Font;
     1830  end;
     1831
     1832  TExposedCustomEdit = class(TCustomEdit)
     1833  public
     1834    property BorderStyle;
     1835    property ReadOnly;
     1836  end;
     1837
     1838procedure UpdateColorsFor508Compliance(control: TControl; InputEditControl: boolean = FALSE);
     1839var
     1840  BitMapLevelCheck: integer;
     1841  Level: integer;
     1842
     1843
     1844  procedure BlackColorSchemeUpdate(control: TControl);
     1845  var
     1846    bitmap: TBitMap;
     1847    edit: TExposedCustomEdit;
     1848    x,y: integer;
     1849    cbmCtrl: IORBlackColorModeCompatible;
     1850
     1851  begin
     1852    if uBlackColorScheme then
     1853    begin
     1854      if Level < BitMapLevelCheck then
     1855      begin
     1856        if control.GetInterface(IORBlackColorModeCompatible, cbmCtrl) then
     1857        begin
     1858          cbmCtrl.SetBlackColorMode(TRUE);
     1859          BitMapLevelCheck := Level;
     1860          cbmCtrl := nil;
     1861        end
     1862        else
     1863        begin
     1864          if (control is TBitBtn) then
     1865          begin
     1866            bitmap := TBitBtn(control).Glyph;
     1867            for x := 0 to bitmap.Width-1 do
     1868            begin
     1869              for y := 0 to bitmap.Height-1 do
     1870              begin
     1871                if ColorToRGB(bitmap.Canvas.Pixels[x,y]) = PURE_BLACK then
     1872                  bitmap.Canvas.Pixels[x,y] := clWindowText;
     1873              end;
     1874            end;
     1875          end;
     1876        end;
     1877      end;
     1878
     1879      if (control is TCustomEdit) and InputEditControl then
     1880      begin
     1881        edit := TExposedCustomEdit(control);
     1882        if (edit.BorderStyle = bsNone) then
     1883          edit.Color := uBorderlessWindowColorWhenBlack;
     1884      end;
     1885
     1886    end;
     1887  end;
     1888
     1889  procedure ComponentUpdateColorsFor508Compliance(control: TControl);
     1890  var
     1891    OldComponentColor, OldFontColor, NewComponentColor, NewFontColor: TColor;
     1892  begin
     1893    OldComponentColor := TExposedControl(control).Color;
     1894    OldFontColor := TExposedControl(control).Font.Color;
     1895    NewComponentColor := Get508CompliantColor(OldComponentColor);
     1896    if NewComponentColor = clInfoBk then
     1897    begin
     1898      if (OldFontColor = clInfoBk) or (OldFontColor = clCream) then
     1899        NewFontColor := clInfoBk // used for hiding text
     1900      else
     1901        NewFontColor := clInfoText;
     1902    end
    14831903    else
    1484       uReadOnlyColor := clWindow;
    1485   end;
    1486   Result := uReadOnlyColor;
     1904      NewFontColor := Get508CompliantColor(OldFontColor);
     1905    if NewComponentColor <> OldComponentColor then
     1906      TExposedControl(control).Color := NewComponentColor;
     1907    if NewFontColor <> OldFontColor then
     1908      TExposedControl(control).Font.Color := NewFontColor;
     1909    BlackColorSchemeUpdate(control);
     1910  end;
     1911
     1912  procedure ScanAllComponents(control: TControl);
     1913  var
     1914    i: integer;
     1915
     1916  begin
     1917    ComponentUpdateColorsFor508Compliance(Control);
     1918    if control is TWinControl then
     1919    begin
     1920      inc(Level);
     1921      try
     1922        for i := 0 to TWinControl(Control).ControlCount-1 do
     1923        begin
     1924          ScanAllComponents(TWinControl(Control).Controls[i]);
     1925        end;
     1926      finally
     1927        dec(Level);
     1928        if BitMapLevelCheck = Level then
     1929          BitMapLevelCheck := MaxInt;
     1930      end;
     1931    end;
     1932  end;
     1933
     1934begin
     1935  if NormalColorScheme then exit;
     1936  BitMapLevelCheck := MaxInt;
     1937  Level := 0;
     1938  ScanAllComponents(control);
     1939end;
     1940
     1941procedure UpdateReadOnlyColorScheme(Control: TControl; ReadOnly: boolean);
     1942begin
     1943  with TExposedControl(Control) do
     1944  begin
     1945    if ReadOnly then
     1946    begin
     1947      Color := Get508CompliantColor(clCream);
     1948      Font.Color := clInfoText;
     1949    end
     1950    else
     1951    begin
     1952      Color := clWindow;
     1953      Font.Color := clWindowText;
     1954    end;
     1955  end;
    14871956end;
    14881957
    … …  
    15211990    end;
    15221991    Canvas.FillRect(ARect);
    1523     Canvas.Pen.Color := clSilver;
     1992    Canvas.Pen.Color := Get508CompliantColor(clSilver);
    15241993    Canvas.MoveTo(ARect.Left, ARect.Bottom - 1);
    15251994    Canvas.LineTo(ARect.Right, ARect.Bottom - 1);
    … …  
    17142183begin
    17152184  Result := Boolean(Hi(GetKeyState(VK_TAB))) and not Boolean(Hi(GetKeyState(VK_SHIFT)));
     2185  Result := Result and not Boolean(Hi(GetKeyState(VK_CONTROL)));
    17162186end;
    17172187
    … …  
    17192189begin
    17202190  Result := Boolean(Hi(GetKeyState(VK_TAB))) and Boolean(Hi(GetKeyState(VK_SHIFT)));
    1721 end;
    1722 
     2191  Result := Result and not Boolean(Hi(GetKeyState(VK_CONTROL)));
     2192end;
     2193
     2194function EnterIsPressed : Boolean;
     2195begin
     2196  Result := Boolean(Hi(GetKeyState(VK_RETURN)));
     2197end;
    17232198
    17242199initialization
    … …  
    17262201  FBaseFont.Name := BaseFontName;
    17272202  FBaseFont.Size := BaseFontSize;
     2203  ScrollBarHeight := GetSystemMetrics(SM_CYHSCROLL);
     2204  AlignList := TStringList.Create;
     2205  AnchorList := TStringList.Create;
     2206  PURE_BLACK := ColorToRGB(clBlack);
    17282207
    17292208finalization
    17302209  FBaseFont.Free;
    17312210  KillObj(@IdleCaller);
     2211  FreeAndNil(AlignList);
     2212  FreeAndNil(AnchorList);
    17322213
    17332214end.

  • cprs/trunk/CPRS-Lib/ORNet.pas

    r456 r829  
    4343{$ENDIF}
    4444  RPCLastCall: string;
     45
     46  AppStartedCursorForm: TForm = nil;
    4547
    4648implementation
    … …  
    263265  AStringList.Add(' ');
    264266  AStringList.Add('Results -----------------------------------------------------------------');
    265   AStringList.AddStrings(RPCBrokerV.Results);
     267  FastAddStrings(RPCBrokerV.Results, AStringList);
    266268  uCallList.Add(AStringList);
    267269  if uShowRPCs then StatusText('');
    … …  
    347349end;
    348350
     351function GetRPCCursor: TCursor;
     352var
     353  pt: TPoint;
     354begin
     355  Result := crHourGlass;
     356  if assigned(AppStartedCursorForm) and (AppStartedCursorForm.Visible) then
     357  begin
     358    pt := Mouse.CursorPos;
     359    if PtInRect(AppStartedCursorForm.BoundsRect, pt) then
     360      Result := crAppStart;   
     361  end;
     362end;
     363
    349364procedure CallV(const RPCName: string; const AParam: array of const);
    350365{ calls the broker leaving results in results property which must be read by caller }
    … …  
    353368begin
    354369  SavedCursor := Screen.Cursor;
    355   Screen.Cursor := crHourGlass;
     370  Screen.Cursor := GetRPCCursor;
    356371  SetParams(RPCName, AParam);
    357372  CallBroker;  //RPCBrokerV.Call;
    … …  
    365380begin
    366381  SavedCursor := Screen.Cursor;
    367   Screen.Cursor := crHourGlass;
     382  Screen.Cursor := GetRPCCursor;
    368383  SetParams(RPCName, AParam);
    369384  CallBroker;  //RPCBrokerV.Call;
    … …  
    379394  if ReturnData = nil then raise Exception.Create('TString not created');
    380395  SavedCursor := Screen.Cursor;
    381   Screen.Cursor := crHourGlass;
     396  Screen.Cursor := GetRPCCursor;
    382397  SetParams(RPCName, AParam);
    383398  CallBroker;  //RPCBrokerV.Call;
    384   ReturnData.Assign(RPCBrokerV.Results);
     399  FastAssign(RPCBrokerV.Results, ReturnData);
    385400  Screen.Cursor := SavedCursor;
    386401end;
    … …  
    395410begin
    396411  SavedCursor := Screen.Cursor;
    397   Screen.Cursor := crHourGlass;
     412  Screen.Cursor := GetRPCCursor;
    398413  SetParams(RPCName, AParam);
    399414  RPCBrokerV.Call;
    … …  
    450465procedure LoadRPCData(Dest: TStrings; ID: Integer);
    451466begin
    452   if (ID > -1) and (ID < uCallList.Count) then Dest.Assign(TStringList(uCallList.Items[ID]));
     467  if (ID > -1) and (ID < uCallList.Count) then FastAssign(TStringList(uCallList.Items[ID]), Dest);
    453468end;
    454469

  • cprs/trunk/CPRS-Lib/ORSystem.pas

    r456 r829  
    22
    33{$O-}
     4{$WARN SYMBOL_PLATFORM OFF}
    45
    56interface
    … …  
    1920  CPRS_LAST_DATE = 'Software\Vista\CPRS\DateUpdated';
    2021
    21   { values that can be passed to FileVersionValue }
    22   FILE_VER_COMPANYNAME      = '\StringFileInfo\040904E4\CompanyName';
    23   FILE_VER_FILEDESCRIPTION  = '\StringFileInfo\040904E4\FileDescription';
    24   FILE_VER_FILEVERSION      = '\StringFileInfo\040904E4\FileVersion';
    25   FILE_VER_INTERNALNAME     = '\StringFileInfo\040904E4\InternalName';
    26   FILE_VER_LEGALCOPYRIGHT   = '\StringFileInfo\040904E4\LegalCopyright';
    27   FILE_VER_ORIGINALFILENAME = '\StringFileInfo\040904E4\OriginalFilename';
    28   FILE_VER_PRODUCTNAME      = '\StringFileInfo\040904E4\ProductName';
    29   FILE_VER_PRODUCTVERSION   = '\StringFileInfo\040904E4\ProductVersion';
    30   FILE_VER_COMMENTS         = '\StringFileInfo\040904E4\Comments';
    31 
    32 
    3322function AppOutOfDate(AppName: string): Boolean;
    3423function ClientVersion(const AFileName: string): string;
    … …  
    4029//procedure FileCopy(const FromFileName, ToFileName: string);
    4130//procedure FileCopyWithDate(const FromFileName, ToFileName: string);
    42 function FileVersionValue(const AFileName, AValueName: string): string;
    4331function FullToFilePart(const AFileName: string): string;
    4432function FullToPathPart(const AFileName: string): string;
    … …  
    6048procedure RunProgram(const AppName: string);
    6149function UpdateSelf: Boolean;
     50function BorlandDLLVersionOK: boolean;
    6251
    6352implementation
    … …  
    11099  // check for different file date in the gold directory
    111100  GoldName := RegReadStr(CPRS_REG_GOLD);
    112   if Length(GoldName) = 0 then Exit;
     101  if (Length(GoldName) = 0)  then exit;
     102  if not DirectoryExists(GoldName) then
     103  begin
     104    if Pos('"', Goldname) > 0 then
     105    begin
     106      Goldname := Copy(GoldName, 2, MaxInt);
     107      if Pos('"', Goldname) > 0 then
     108        Goldname := Copy(GoldName, 1, Length(GoldName) - 1);
     109    end;
     110  end;
     111  if (not DirectoryExists(GoldName)) then Exit;
    113112  GoldName := GoldName + FullToFilePart(AppName);
    114113  if FileExists(GoldName) then
    … …  
    139138                                                     IntToStr(HIWORD(dwFileVersionLS)) + '.' +
    140139                                                     IntToStr(LOWORD(dwFileVersionLS));
    141   end;
    142 end;
    143 
    144 function FileVersionValue(const AFileName, AValueName: string): string;
    145 type
    146   PValBuf = ^TValBuf;
    147   TValBuf = array[0..255] of Char;
    148 var
    149   VerSize, ValSize, AHandle: DWORD;
    150   VerBuf: Pointer;
    151   ValBuf: PValBuf;
    152 begin
    153   Result := '';
    154   VerSize:=GetFileVersionInfoSize(PChar(AFileName), AHandle);
    155   if VerSize > 0 then
    156   begin
    157     GetMem(VerBuf, VerSize);
    158     try
    159       GetFileVersionInfo(PChar(AFileName), AHandle, VerSize, VerBuf);
    160       VerQueryValue(VerBuf, PChar(AValueName), Pointer(ValBuf), ValSize);
    161       SetString(Result, ValBuf^, ValSize);
    162     finally
    163       FreeMem(VerBuf);
    164     end;
    165140  end;
    166141end;
    … …  
    551526*)
    552527
     528function BorlandDLLVersionOK: boolean;
     529const
     530  DLL_CURRENT_VERSION = 10;
     531  TC_DLL_ERR   = 'ERROR - BORLNDMM.DLL';
     532  TX_NO_RUN    = 'This version of CPRS is unable to run because' + CRLF;
     533  TX_NO_DLL    = 'no copy of BORLNDMM.DLL can be found' + CRLF +
     534                 'in your workstation''s current PATH.';
     535  TX_OLD_DLL1  = 'the copy of BORLNDMM.DLL located at:' + CRLF + CRLF;
     536  TX_OLD_DLL2  = CRLF + CRLF + 'is out of date  (Version ';
     537  TX_CALL_IRM  = CRLF + CRLF +'Please contact IRM for assistance.';
     538var
     539  DLLHandle: HMODULE;
     540  DLLNamePath: array[0..261] of Char;
     541  DLLVersion: string;
     542begin
     543  Result := TRUE;
     544  DLLHandle := GetModuleHandle('BORLNDMM.DLL');
     545  if DLLHandle <=0 then
     546  begin
     547    InfoBox(TX_NO_RUN + TX_NO_DLL + TX_CALL_IRM, TC_DLL_ERR, MB_ICONERROR or MB_OK);
     548    Result := FALSE;
     549    Exit;
     550  end;
     551  Windows.GetModuleFileName(DLLHandle, DLLNamePath, 261);
     552  DLLVersion := ClientVersion(DLLNamePath);
     553  if StrToIntDef(Piece(DLLVersion, '.', 1), 0) < DLL_CURRENT_VERSION then
     554  begin
     555    InfoBox(TX_NO_RUN + TX_OLD_DLL1 + '   ' + DLLNamePath + TX_OLD_DLL2 + DLLVersion + ')' +
     556            TX_CALL_IRM, TC_DLL_ERR, MB_ICONERROR or MB_OK);
     557    Result := false;
     558  end;
     559end;
     560
    553561end.
Note: See TracChangeset for help on using the changeset viewer.