Index: cprs/trunk/CPRS-Lib/Borland2006.dpk =================================================================== --- cprs/trunk/CPRS-Lib/Borland2006.dpk (revision 829) +++ cprs/trunk/CPRS-Lib/Borland2006.dpk (revision 829) @@ -0,0 +1,35 @@ +package Borland2006; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS ON} +{$RANGECHECKS ON} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'Components downloaded from Borland''s Web Page'} +{$DESIGNONLY} +{$IMPLICITBUILD OFF} + +requires + vcl; + +contains + Menubar in 'Menubar.pas'; + +end. Index: cprs/trunk/CPRS-Lib/Borland2006.drc =================================================================== --- cprs/trunk/CPRS-Lib/Borland2006.drc (revision 829) +++ cprs/trunk/CPRS-Lib/Borland2006.drc (revision 829) @@ -0,0 +1,14 @@ +/* VER180 + Generated by the Borland Delphi Pascal Compiler + because -GD or --drc was supplied to the compiler. + + This file contains compiler-generated resources that + were bound to the executable. + If this file is empty, then no compiler-generated + resources were bound to the produced executable. +*/ + +STRINGTABLE +BEGIN +END + Index: cprs/trunk/CPRS-Lib/Copy of ORCtrlLib60.cfg =================================================================== --- cprs/trunk/CPRS-Lib/Copy of ORCtrlLib60.cfg (revision 456) +++ (revision ) @@ -1,42 +1,0 @@ --$A8 --$B- --$C+ --$D+ --$E- --$F- --$G+ --$H+ --$I+ --$J+ --$K- --$L+ --$M- --$N+ --$O+ --$P+ --$Q+ --$R+ --$S- --$T- --$U- --$V+ --$W+ --$X+ --$YD --$Z1 --GD --cg --AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; --H+ --W+ --M --$M16384,1048576 --K$00400000 --E"c:\program files\borland\delphi6\dev\exesave" --N"..\Packages" --LE"..\Packages" --LN"..\Packages" --U"..\cprs-lib;..\Packages" --O"..\cprs-lib;..\Packages" --I"..\cprs-lib;..\Packages" --R"..\cprs-lib;..\Packages" Index: cprs/trunk/CPRS-Lib/Copy of ORCtrlLib60.dof =================================================================== --- cprs/trunk/CPRS-Lib/Copy of ORCtrlLib60.dof (revision 456) +++ (revision ) @@ -1,141 +1,0 @@ -[FileVersion] -Version=6.0 -[Compiler] -A=8 -B=0 -C=1 -D=1 -E=0 -F=0 -G=1 -H=1 -I=1 -J=1 -K=0 -L=1 -M=0 -N=1 -O=1 -P=1 -Q=1 -R=1 -S=0 -T=0 -U=0 -V=1 -W=1 -X=1 -Y=1 -Z=1 -ShowHints=1 -ShowWarnings=1 -UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; -[Linker] -MapFile=3 -OutputObjs=0 -ConsoleApp=1 -DebugInfo=0 -RemoteSymbols=0 -MinStackSize=16384 -MaxStackSize=1048576 -ImageBase=4194304 -ExeDescription=CPRS Custom Controls -[Directories] -OutputDir=$(DELPHI)\dev\exesave -UnitOutputDir=..\Packages -PackageDLLOutputDir=..\Packages -PackageDCPOutputDir=..\Packages -SearchPath=..\cprs-lib;..\Packages -Packages=Vcl40;Vclx40;Vcldb40;vcldbx40;VclSmp40;Qrpt40;TeeUI40;teedb40;tee40;ibevnt40;nmfast40;VistABroker -Conditionals= -DebugSourceDirs=..\Packages -UsePackages=0 -[Parameters] -RunParams= -HostApplication= -Launcher= -UseLauncher=0 -DebugCWD= -[Language] -ActiveLang= -ProjectLang=$00000409 -RootDir= -[Version Info] -IncludeVerInfo=1 -AutoIncBuild=0 -MajorVer=1 -MinorVer=0 -Release=0 -Build=0 -Debug=0 -PreRelease=0 -Special=0 -Private=0 -DLL=0 -Locale=1033 -CodePage=1252 -[Version Info Keys] -CompanyName= -FileDescription= -FileVersion=1.0.0.0 -InternalName= -LegalCopyright= -LegalTrademarks= -OriginalFilename= -ProductName= -ProductVersion=1.0.0.0 -Comments= -[Excluded Packages] -C:\Program Files\Borland\Delphi6\Projects\Bpl\SharedRPCBroker_D60.bpl=VistA SharedBroker Components -[HistoryLists\hlDebugSourcePath] -Count=1 -Item0=..\Packages -[HistoryLists\hlUnitAliases] -Count=1 -Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; -[HistoryLists\hlSearchPath] -Count=10 -Item0=..\cprs-lib;..\Packages -Item1=..\cprs-lib;..\Packages;..\cprs-chart;..\cprs-chart\dcu -Item2=d:\vista\main\cprs-lib;d:\vista\main\Packages -Item3=d:\vista\main\cprs-lib;d:\program files\vista\broker\bdk32\d5 -Item4=d:\vista\main\cprs-chart;d:\vista\main\cprs-lib;d:\vista\main\cprs-chart\encounter;d:\vista\main\cprs-chart\consults -Item5=d:\vista\main\cprs-lib -Item6=\Dev\CPRS\main\CPRS-Lib -Item7=C:\Dev\CPRS\main\CPRS-Lib -Item8=\Projects\Perforce\main\CPRS-Lib -Item9=$(DELPHI)\Projects\Current\CPRS-Lib -[HistoryLists\hlUnitOutputDirectory] -Count=10 -Item0=..\Packages -Item1=..\cprs-lib\dcu -Item2=..\cprs-lib -Item3=d:\vista\main\cprs-lib\DCU -Item4=d:\vista\main\cprs-lib\DCUSave -Item5=d:\vista\main\cprs-chart\dcu -Item6=\Dev\DCUSave -Item7=C:\Dev\DCUSave -Item8=\Projects\DCUSave -Item9=$(DELPHI)\Projects\DCUSave -[HistoryLists\hlOutputDirectorry] -Count=2 -Item0=$(DELPHI)\dev\exesave -Item1=d:\vista\main\cprs-chart -[HistoryLists\hlBPLOutput] -Count=7 -Item0=..\Packages -Item1=d:\vista\main\Packages -Item2=d:\vista\main\cprs-lib -Item3=\Dev\Packages -Item4=C:\Dev\Packages -Item5=\Projects\Packages -Item6=$(DELPHI)\Projects\Packages -[HistoryLists\hlDCPOutput] -Count=7 -Item0=..\Packages -Item1=d:\vista\main\Packages -Item2=d:\vista\main\cprs-lib -Item3=\Dev\Packages -Item4=C:\Dev\Packages -Item5=\Projects\Packages -Item6=$(DELPHI)\Projects\Packages Index: cprs/trunk/CPRS-Lib/Copy of ORCtrlLib60.drc =================================================================== --- cprs/trunk/CPRS-Lib/Copy of ORCtrlLib60.drc (revision 456) +++ (revision ) @@ -1,14 +1,0 @@ -/* VER140 - Generated by the Borland Delphi Pascal Compiler - because -GD or --drc was supplied to the compiler. - - This file contains compiler-generated resources that - were bound to the executable. - If this file is empty, then no compiler-generated - resources were bound to the produced executable. -*/ - -STRINGTABLE -BEGIN -END - Index: cprs/trunk/CPRS-Lib/Copy of ORCtrlLib60.dsk =================================================================== --- cprs/trunk/CPRS-Lib/Copy of ORCtrlLib60.dsk (revision 456) +++ (revision ) @@ -1,498 +1,0 @@ -[Closed Files] -File_0=SourceModule,'D:\vista\cprs\OR_3_195V25\CPRS-Lib\uStaticText.pas',0,1,1,1,1,0,0 -File_1=SourceModule,'D:\vista\cprs\OR_3_195V25\CPRS-Chart\unit2.pas',0,1,1,1,11,0,0 -File_2=SourceModule,'D:\vista\cprs\main\CPRS-Chart\uSignItems.pas',0,1,1044,54,1060,0,0 -File_3=SourceModule,'D:\vista\cprs\OR_3_215V26\CPRS-Chart\uSignItems.pas',0,1,1044,54,1060,0,0 -File_4=SourceModule,'D:\vista\cprs\OR_3_215V26\CPRS-Chart\fReview.pas',0,1,1833,42,1841,1,0 -File_5=SourceModule,'D:\vista\cprs\main\CPRS-Chart\fReview.pas',0,1,1830,44,1857,1,0 -File_6=SourceModule,'D:\vista\cprs\OR_3_195V25\CPRS-Lib\ORCtrls.pas',0,1,1,63,30,0,0 -File_7=SourceModule,'C:\PROGRA~1\Vista\BDK32_~1\Source\wsockc.pas',0,1,1455,1,1477,0,0 -File_8=SourceModule,'D:\vista\cprs\OR_3_195V25\CPRS-Chart\VERGENCECONTEXTORLib_TLB.pas',0,1,564,1,586,0,0 - -[Modules] -Module0=D:\vista\cprs\OR_3_195V25\CPRS-Chart\Orders\fOrdersSign.pas -Module1=D:\vista\cprs\OR_3_195V25\CPRS-Chart\fReview.pas -Module2=D:\vista\cprs\OR_3_195V25\CPRS-Chart\uSignItems.pas -Module3=D:\vista\cprs\OR_3_195V25\CPRS-Chart\CPRSChart.dpr -Count=4 -EditWindowCount=1 -PackageWindowCount=1 -TypeLibWindowCount=1 - -[D:\vista\cprs\OR_3_195V25\CPRS-Chart\Orders\fOrdersSign.pas] -ModuleType=SourceModule -FormState=0 -FormOnTop=0 - -[D:\vista\cprs\OR_3_195V25\CPRS-Chart\fReview.pas] -ModuleType=SourceModule -FormState=0 -FormOnTop=0 - -[D:\vista\cprs\OR_3_195V25\CPRS-Chart\uSignItems.pas] -ModuleType=SourceModule -FormState=0 -FormOnTop=0 - -[D:\vista\cprs\OR_3_195V25\CPRS-Chart\CPRSChart.dpr] -ModuleType=SourceModule -FormState=0 -FormOnTop=0 -SymbolFile=D:\vista\cprs\OR_3_195V25\CPRS-Chart\CPRSChart.dsm -ModSinceCompile=1 - -[D:\vista\cprs\OR_3_215V26\CPRS-Lib\ORCtrlLib60.dpk] -FormState=0 -FormOnTop=1 - -[D:\vista\cprs\OR_3_195V25\CPRS-Chart\CPRSChart.tlb] -FormState=0 -FormOnTop=1 - -[D:\Program Files\Borland\Delphi6\Projects\ProjectGroup1.bpg] -FormState=0 -FormOnTop=0 - -[D:\vista\cprs\OR_3_195V25\CPRS-Chart\mCoPayDesc.pas] -FormState=0 -FormOnTop=0 - -[EditWindow0] -ViewCount=4 -CurrentView=3 -View0=0 -View1=1 -View2=2 -View3=3 -CodeExplorer=CodeExplorer@EditWindow0 -MessageView=MessageView@EditWindow0 -Create=1 -Visible=1 -State=0 -Left=1 -Top=104 -Width=1022 -Height=635 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=1014 -ClientHeight=608 -LeftPanelSize=0 -RightPanelSize=0 -BottomPanelSize=0 -BottomPanelClients=MessageView@EditWindow0 -BottomPanelData=00000400010000000B0000004D65737361676556696577F603000000000000021D00000000000000010000000000000000000000000100000000F3030000000000000100000000F3030000000000000100000000F3030000000000000100000000F3030000000000000100000000F3030000000000000100000000F3030000000000000100000000F5030000000000000100000000F5030000000000000100000000F5030000000000000100000000F50300000000000001000000000004000000000000010000000000040000000000000100000000F5030000000000000100000000F503000000000000010000000000040000000000000100000000720400000000000001000000007204000000000000010000000080040000000000000100000000720400000000000001000000007204000000000000010000000072040000000000000100000000750400000000000001000000008004000000000000010000000080040000000000000100000000000400000000000001000000000004000000000000010000000000040000000000000100000000F8030000000000000100000000F8030000000000000100000000F803000000000000010000000000040000000000000100000000F8030000000000000100000000F8030000000000000100000000EF030000000000000100000000EF03000000000000010000000000040000000000000100000000B0020000000000000100000000F5030000000000000100000000F503000000000000010000000000040000000000000100000000F40300000000000001000000000004000000000000010000000000040000000000000100000000F8030000000000000100000000F8030000000000000100000000F803000000000000010000000000040000000000000100000000F80300000000000001000000000004000000000000010000000000040000000000000100000000F803000000000000010000000000040000000000000100000000F8030000000000000100000000F8030000000000000100000000F80300000000000001000000000004000000000000010000000000040000000000000100000000F60300000000000001000000000004000000000000010000000000040000000000000100000000F6030000000000000100000000F6030000000000000100000000F60300000B0000004D65737361676556696577FFFFFFFF - -[View0] -Module=D:\vista\cprs\OR_3_195V25\CPRS-Chart\CPRSChart.dpr -CursorX=28 -CursorY=17 -TopLine=2 -LeftCol=1 - -[View1] -Module=D:\vista\cprs\OR_3_195V25\CPRS-Chart\uSignItems.pas -CursorX=33 -CursorY=325 -TopLine=628 -LeftCol=1 - -[View2] -Module=D:\vista\cprs\OR_3_195V25\CPRS-Chart\fReview.pas -CursorX=36 -CursorY=375 -TopLine=358 -LeftCol=1 - -[View3] -Module=D:\vista\cprs\OR_3_195V25\CPRS-Chart\Orders\fOrdersSign.pas -CursorX=1 -CursorY=1439 -TopLine=1427 -LeftCol=1 - -[PackageWindow0] -Create=1 -Visible=1 -State=0 -Left=260 -Top=260 -Width=368 -Height=244 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=360 -ClientHeight=220 -TBDockHeight=244 -LRDockWidth=368 -Dockable=1 -StatusBar=0 -TextLabels=1 -Toolbar=1 -SectionWidth0=150 -SectionWidth1=210 -Module=D:\vista\cprs\OR_3_215V26\CPRS-Lib\ORCtrlLib60.dpk - -[TypeLibEditWindow0] -Create=1 -Visible=0 -State=0 -Left=200 -Top=103 -Width=650 -Height=446 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=642 -ClientHeight=419 -Module=D:\vista\cprs\OR_3_195V25\CPRS-Chart\CPRSChart.tlb - -[Watches] -Count=4 -Watch0='i',256,0,18,1,1 -Watch1='Piece(lbDiagnosis.Items[i],U,2)',256,0,18,1,1 -Watch2='lbDiagnosis.Items[itemNum]',256,0,18,1,0 -Watch3='lbPersonalDx.Items[J]',256,0,18,1,0 - -[Breakpoints] -Count=6 -Breakpoint0='D:\vista\cprs\OR_3_195V25\CPRS-Chart\uSignItems.pas',130,'',0,1,'',1,0,0,'',1,'','','' -Breakpoint1='D:\vista\cprs\OR_3_195V25\CPRS-Chart\BA\fBAOptionsDiagnoses.pas',410,'',0,1,'',1,0,0,'',1,'','','' -Breakpoint2='D:\vista\cprs\OR_3_195V25\CPRS-Chart\BA\fBAOptionsDiagnoses.pas',414,'',0,1,'',1,0,0,'',1,'','','' -Breakpoint3='D:\vista\cprs\OR_3_195V25\CPRS-Chart\uSignItems.pas',275,'',0,1,'',1,0,0,'',1,'','','' -Breakpoint4='D:\vista\cprs\OR_3_195V25\CPRS-Chart\Orders\fOrdersSign.pas',1099,'',0,1,'',1,0,0,'',1,'','','' -Breakpoint5='D:\vista\cprs\OR_3_195V25\CPRS-Chart\uSignItems.pas',644,'',0,1,'',1,0,0,'',1,'','','' - -[AddressBreakpoints] -Count=0 - -[Main Window] -Create=1 -Visible=1 -State=0 -Left=0 -Top=0 -Width=1024 -Height=105 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=1016 -ClientHeight=78 - -[ProjectManager] -Create=1 -Visible=1 -State=0 -Left=0 -Top=0 -Width=287 -Height=579 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=287 -ClientHeight=579 -TBDockHeight=571 -LRDockWidth=255 -Dockable=1 - -[Components] -Create=1 -Visible=0 -State=0 -Left=420 -Top=251 -Width=183 -Height=266 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=175 -ClientHeight=242 - -[CPUWindow] -Create=1 -Visible=0 -State=0 -Left=159 -Top=109 -Width=819 -Height=551 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=811 -ClientHeight=524 -DumpPane=212 -DisassemblyPane=377 -RegisterPane=231 -FlagPane=120 - -[AlignmentPalette] -Create=1 -Visible=0 -State=0 -Left=200 -Top=107 -Width=156 -Height=82 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=150 -ClientHeight=60 - -[PropertyInspector] -Create=1 -Visible=1 -State=0 -Left=0 -Top=0 -Width=287 -Height=579 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=287 -ClientHeight=579 -TBDockHeight=571 -LRDockWidth=255 -Dockable=1 -SplitPos=131 -ArrangeBy=Name -SelectedItem= -ExpandedItems=Brush,Font.Style -HiddenCategories= - -[WatchWindow] -Create=1 -Visible=1 -State=0 -Left=5 -Top=1 -Width=803 -Height=104 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=795 -ClientHeight=80 -TBDockHeight=149 -LRDockWidth=421 -Dockable=1 - -[BreakpointWindow] -Create=1 -Visible=1 -State=0 -Left=0 -Top=0 -Width=287 -Height=579 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=287 -ClientHeight=579 -TBDockHeight=197 -LRDockWidth=737 -Dockable=1 -Column0Width=151 -Column1Width=75 -Column2Width=200 -Column3Width=200 -Column4Width=75 -Column5Width=75 - -[CallStackWindow] -Create=1 -Visible=0 -State=0 -Left=365 -Top=303 -Width=294 -Height=161 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=286 -ClientHeight=137 -TBDockHeight=161 -LRDockWidth=294 -Dockable=1 - -[ThreadStatusWindow] -Create=1 -Visible=0 -State=0 -Left=0 -Top=0 -Width=1024 -Height=768 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=1016 -ClientHeight=744 -TBDockHeight=152 -LRDockWidth=624 -Dockable=1 -Column0Width=145 -Column1Width=100 -Column2Width=115 -Column3Width=250 - -[ModuleWindow] -Create=1 -Visible=0 -State=0 -Left=18 -Top=9 -Width=913 -Height=719 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=905 -ClientHeight=695 -TBDockHeight=355 -LRDockWidth=638 -Dockable=1 -Column0Width=125 -Column1Width=100 -Column2Width=356 -EntryPointPane=447 -CompUnitPane=530 - -[ObjectTree] -Create=1 -Visible=0 -State=0 -Left=0 -Top=105 -Width=190 -Height=264 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=182 -ClientHeight=240 -TBDockHeight=264 -LRDockWidth=190 -Dockable=1 - -[DebugLogView] -Create=1 -Visible=0 -State=0 -Left=0 -Top=0 -Width=798 -Height=712 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=790 -ClientHeight=688 -TBDockHeight=291 -LRDockWidth=417 -Dockable=1 - -[LocalVarsWindow] -Create=1 -Visible=0 -State=0 -Left=441 -Top=447 -Width=421 -Height=192 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=413 -ClientHeight=168 -TBDockHeight=192 -LRDockWidth=421 -Dockable=1 - -[ToDo List] -Create=1 -Visible=0 -State=0 -Left=107 -Top=48 -Width=866 -Height=649 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=858 -ClientHeight=625 -TBDockHeight=250 -LRDockWidth=713 -Dockable=1 -Column0Width=507 -Column1Width=30 -Column2Width=100 -Column3Width=70 -Column4Width=70 -SortOrder=6 -ShowHints=1 -ShowChecked=1 - -[FPUWindow] -Create=1 -Visible=0 -State=0 -Left=306 -Top=280 -Width=457 -Height=250 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=449 -ClientHeight=223 -RegisterPane=121 -FlagPane=59 - -[CodeExplorer@EditWindow0] -Create=1 -Visible=1 -State=0 -Left=0 -Top=0 -Width=287 -Height=579 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=287 -ClientHeight=579 -TBDockHeight=305 -LRDockWidth=140 -Dockable=1 - -[MessageView@EditWindow0] -Create=1 -Visible=0 -State=0 -Left=12 -Top=0 -Width=1002 -Height=29 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=1002 -ClientHeight=29 -TBDockHeight=29 -LRDockWidth=443 -Dockable=1 - -[DockHosts] -DockHostCount=1 - -[DockSite0] -DockSiteType=1 -Create=1 -Visible=1 -State=0 -Left=1 -Top=104 -Width=303 -Height=632 -MaxLeft=-1 -MaxTop=-1 -ClientWidth=295 -ClientHeight=608 -TBDockHeight=659 -LRDockWidth=263 -Dockable=1 -TabPosition=0 -ActiveTab=Object Inspector -TabDockClients=PropertyInspector,ProjectManager,BreakpointWindow,CodeExplorer@EditWindow0 - Index: cprs/trunk/CPRS-Lib/Copy of ORDateLib60.cfg =================================================================== --- cprs/trunk/CPRS-Lib/Copy of ORDateLib60.cfg (revision 456) +++ (revision ) @@ -1,42 +1,0 @@ --$A8 --$B- --$C+ --$D+ --$E- --$F- --$G+ --$H+ --$I+ --$J+ --$K- --$L+ --$M- --$N+ --$O+ --$P+ --$Q+ --$R+ --$S- --$T- --$U- --$V+ --$W+ --$X+ --$YD --$Z1 --GD --cg --AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; --H+ --W+ --M --$M16384,1048576 --K$00400000 --E"c:\program files\borland\delphi6\dev\exesave" --N"..\cprs-lib\DCU" --LE"..\Packages" --LN"..\Packages" --U"..\cprs-lib;..\Packages" --O"..\cprs-lib;..\Packages" --I"..\cprs-lib;..\Packages" --R"..\cprs-lib;..\Packages" Index: cprs/trunk/CPRS-Lib/Copy of ORDateLib60.dof =================================================================== --- cprs/trunk/CPRS-Lib/Copy of ORDateLib60.dof (revision 456) +++ (revision ) @@ -1,137 +1,0 @@ -[FileVersion] -Version=6.0 -[Compiler] -A=8 -B=0 -C=1 -D=1 -E=0 -F=0 -G=1 -H=1 -I=1 -J=1 -K=0 -L=1 -M=0 -N=1 -O=1 -P=1 -Q=1 -R=1 -S=0 -T=0 -U=0 -V=1 -W=1 -X=1 -Y=1 -Z=1 -ShowHints=1 -ShowWarnings=1 -UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; -[Linker] -MapFile=3 -OutputObjs=0 -ConsoleApp=1 -DebugInfo=0 -RemoteSymbols=0 -MinStackSize=16384 -MaxStackSize=1048576 -ImageBase=4194304 -ExeDescription=CPRS Date/Time Dialogs -[Directories] -OutputDir=$(DELPHI)\dev\exesave -UnitOutputDir=..\cprs-lib\DCU -PackageDLLOutputDir=..\Packages -PackageDCPOutputDir=..\Packages -SearchPath=..\cprs-lib;..\Packages -Packages=Vcl40;Vclx40;Vcldb40;vcldbx40;VclSmp40;Qrpt40;TeeUI40;teedb40;tee40;ibevnt40;nmfast40;VistABroker -Conditionals= -DebugSourceDirs= -UsePackages=0 -[Parameters] -RunParams= -HostApplication= -Launcher= -UseLauncher=0 -DebugCWD= -[Language] -ActiveLang= -ProjectLang=$00000409 -RootDir= -[Version Info] -IncludeVerInfo=1 -AutoIncBuild=0 -MajorVer=1 -MinorVer=0 -Release=0 -Build=0 -Debug=0 -PreRelease=0 -Special=0 -Private=0 -DLL=0 -Locale=1033 -CodePage=1252 -[Version Info Keys] -CompanyName= -FileDescription= -FileVersion=1.0.0.0 -InternalName= -LegalCopyright= -LegalTrademarks= -OriginalFilename= -ProductName= -ProductVersion=1.0.0.0 -Comments= -[Excluded Packages] -C:\Program Files\Borland\Delphi6\Projects\Bpl\SharedRPCBroker_D60.bpl=VistA SharedBroker Components -[HistoryLists\hlUnitAliases] -Count=1 -Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; -[HistoryLists\hlSearchPath] -Count=11 -Item0=..\cprs-lib;..\Packages -Item1=..\cprs-lib;..\Packages;c:\program files\vista\bdk32\d6 -Item2=..\cprs-lib;..\Packages;..\cprs-chart;..\cprs-chart\dcu -Item3=d:\vista\main\cprs-lib;d:\vista\main\Packages -Item4=d:\vista\main\cprs-lib;d:\program files\vista\broker\bdk32\d5 -Item5=d:\vista\main\cprs-chart;d:\vista\main\cprs-lib;d:\vista\main\cprs-chart\encounter;d:\vista\main\cprs-chart\consults -Item6=d:\vista\main\cprs-lib -Item7=\Dev\CPRS\main\CPRS-Lib -Item8=C:\Dev\CPRS\main\CPRS-Lib -Item9=\Projects\Perforce\main\CPRS-Lib -Item10=$(DELPHI)\Projects\Current\CPRS-Lib -[HistoryLists\hlUnitOutputDirectory] -Count=8 -Item0=..\cprs-lib\DCU -Item1=d:\vista\main\cprs-lib\DCU -Item2=d:\vista\main\cprs-lib\DCUSave -Item3=d:\vista\main\cprs-chart\dcu -Item4=\Dev\DCUSave -Item5=C:\Dev\DCUSave -Item6=\Projects\DCUSave -Item7=$(DELPHI)\Projects\DCUSave -[HistoryLists\hlOutputDirectorry] -Count=2 -Item0=$(DELPHI)\dev\exesave -Item1=d:\vista\main\cprs-chart -[HistoryLists\hlBPLOutput] -Count=7 -Item0=..\Packages -Item1=d:\vista\main\Packages -Item2=d:\vista\main\cprs-lib -Item3=\Dev\Packages -Item4=C:\Dev\Packages -Item5=\Projects\Packages -Item6=$(DELPHI)\Projects\Packages -[HistoryLists\hlDCPOutput] -Count=7 -Item0=..\Packages -Item1=d:\vista\main\Packages -Item2=d:\vista\main\cprs-lib -Item3=\Dev\Packages -Item4=C:\Dev\Packages -Item5=\Projects\Packages -Item6=$(DELPHI)\Projects\Packages Index: cprs/trunk/CPRS-Lib/Copy of ORDateLib60.drc =================================================================== --- cprs/trunk/CPRS-Lib/Copy of ORDateLib60.drc (revision 456) +++ (revision ) @@ -1,14 +1,0 @@ -/* VER140 - Generated by the Borland Delphi Pascal Compiler - because -GD or --drc was supplied to the compiler. - - This file contains compiler-generated resources that - were bound to the executable. - If this file is empty, then no compiler-generated - resources were bound to the produced executable. -*/ - -STRINGTABLE -BEGIN -END - Index: cprs/trunk/CPRS-Lib/Copy of VA10.cfg =================================================================== --- cprs/trunk/CPRS-Lib/Copy of VA10.cfg (revision 456) +++ (revision ) @@ -1,42 +1,0 @@ --$A8 --$B- --$C- --$D+ --$E- --$F- --$G+ --$H+ --$I+ --$J+ --$K- --$L+ --$M- --$N+ --$O+ --$P+ --$Q+ --$R+ --$S- --$T- --$U- --$V+ --$W+ --$X+ --$YD --$Z1 --GD --cg --AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; --H+ --W+ --M --$M16384,1048576 --K$00400000 --E"c:\program files\borland\delphi6\dev\exesave" --N"..\cprs-lib\DCU" --LE"..\Packages" --LN"..\Packages" --U"..\cprs-lib;..\Packages" --O"..\cprs-lib;..\Packages" --I"..\cprs-lib;..\Packages" --R"..\cprs-lib;..\Packages" Index: cprs/trunk/CPRS-Lib/Copy of VA10.dof =================================================================== --- cprs/trunk/CPRS-Lib/Copy of VA10.dof (revision 456) +++ (revision ) @@ -1,133 +1,0 @@ -[FileVersion] -Version=6.0 -[Compiler] -A=8 -B=0 -C=0 -D=1 -E=0 -F=0 -G=1 -H=1 -I=1 -J=1 -K=0 -L=1 -M=0 -N=1 -O=1 -P=1 -Q=1 -R=1 -S=0 -T=0 -U=0 -V=1 -W=1 -X=1 -Y=1 -Z=1 -ShowHints=1 -ShowWarnings=1 -UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; -[Linker] -MapFile=3 -OutputObjs=0 -ConsoleApp=1 -DebugInfo=0 -RemoteSymbols=0 -MinStackSize=16384 -MaxStackSize=1048576 -ImageBase=4194304 -ExeDescription=Wrap Grid -[Directories] -OutputDir=$(DELPHI)\dev\exesave -UnitOutputDir=..\cprs-lib\DCU -PackageDLLOutputDir=..\Packages -PackageDCPOutputDir=..\Packages -SearchPath=..\cprs-lib;..\Packages -Packages=Vcl40;Vclx40;Vcldb40;vcldbx40;VclSmp40;Qrpt40;TeeUI40;teedb40;tee40;ibevnt40;nmfast40;VistABroker -Conditionals= -DebugSourceDirs= -UsePackages=0 -[Parameters] -RunParams= -HostApplication= -Launcher= -UseLauncher=0 -DebugCWD= -[Language] -ActiveLang= -ProjectLang=$00000409 -RootDir= -[Version Info] -IncludeVerInfo=1 -AutoIncBuild=0 -MajorVer=1 -MinorVer=0 -Release=0 -Build=0 -Debug=0 -PreRelease=0 -Special=0 -Private=0 -DLL=0 -Locale=1033 -CodePage=1252 -[Version Info Keys] -CompanyName= -FileDescription= -FileVersion=1.0.0.0 -InternalName= -LegalCopyright= -LegalTrademarks= -OriginalFilename= -ProductName= -ProductVersion=1.0.0.0 -Comments= -[HistoryLists\hlUnitAliases] -Count=1 -Item0=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; -[HistoryLists\hlSearchPath] -Count=9 -Item0=..\cprs-lib;..\Packages -Item1=d:\vista\main\cprs-lib;d:\vista\main\Packages -Item2=d:\vista\main\cprs-lib;d:\program files\vista\broker\bdk32\d5 -Item3=d:\vista\main\cprs-chart;d:\vista\main\cprs-lib;d:\vista\main\cprs-chart\encounter;d:\vista\main\cprs-chart\consults -Item4=d:\vista\main\cprs-lib -Item5=\Dev\CPRS\main\CPRS-Lib -Item6=C:\Dev\CPRS\main\CPRS-Lib -Item7=\Projects\Perforce\main\CPRS-Lib -Item8=$(DELPHI)\Projects\Current\CPRS-Lib -[HistoryLists\hlUnitOutputDirectory] -Count=8 -Item0=..\cprs-lib\DCU -Item1=d:\vista\main\cprs-lib\DCU -Item2=d:\vista\main\cprs-lib\DCUSave -Item3=d:\vista\main\cprs-chart\dcu -Item4=\Dev\DCUSave -Item5=C:\Dev\DCUSave -Item6=\Projects\DCUSave -Item7=$(DELPHI)\Projects\DCUSave -[HistoryLists\hlOutputDirectorry] -Count=2 -Item0=$(DELPHI)\dev\exesave -Item1=d:\vista\main\cprs-chart -[HistoryLists\hlBPLOutput] -Count=7 -Item0=..\Packages -Item1=d:\vista\main\Packages -Item2=d:\vista\main\cprs-lib -Item3=\Dev\Packages -Item4=C:\Dev\Packages -Item5=\Projects\Packages -Item6=$(DELPHI)\Projects\Packages -[HistoryLists\hlDCPOutput] -Count=7 -Item0=..\Packages -Item1=d:\vista\main\Packages -Item2=d:\vista\main\cprs-lib -Item3=\Dev\Packages -Item4=C:\Dev\Packages -Item5=\Projects\Packages -Item6=$(DELPHI)\Projects\Packages Index: cprs/trunk/CPRS-Lib/Copy of VA10.drc =================================================================== --- cprs/trunk/CPRS-Lib/Copy of VA10.drc (revision 456) +++ (revision ) @@ -1,14 +1,0 @@ -/* VER140 - Generated by the Borland Delphi Pascal Compiler - because -GD or --drc was supplied to the compiler. - - This file contains compiler-generated resources that - were bound to the executable. - If this file is empty, then no compiler-generated - resources were bound to the produced executable. -*/ - -STRINGTABLE -BEGIN -END - Index: cprs/trunk/CPRS-Lib/OR2006Compatibility.dfm =================================================================== --- cprs/trunk/CPRS-Lib/OR2006Compatibility.dfm (revision 829) +++ cprs/trunk/CPRS-Lib/OR2006Compatibility.dfm (revision 829) @@ -0,0 +1,18 @@ +object frm2006Compatibility: Tfrm2006Compatibility + Left = 0 + Top = 0 + Width = 231 + Height = 162 + AutoScroll = True + Caption = 'frm2006Compatibility' + Color = clBtnFace + Font.Charset = DEFAULT_CHARSET + Font.Color = clWindowText + Font.Height = -11 + Font.Name = 'Tahoma' + Font.Style = [] + OldCreateOrder = False + Position = poDesigned + PixelsPerInch = 96 + TextHeight = 13 +end Index: cprs/trunk/CPRS-Lib/OR2006Compatibility.pas =================================================================== --- cprs/trunk/CPRS-Lib/OR2006Compatibility.pas (revision 829) +++ cprs/trunk/CPRS-Lib/OR2006Compatibility.pas (revision 829) @@ -0,0 +1,36 @@ +unit OR2006Compatibility; + +interface + +uses + Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, + Dialogs; + +{$IFDEF VER140} + Compile Error // should not be used in Delphi 6! +{$ENDIF} + +type + Tfrm2006Compatibility = class(TForm) + public + constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override; + end; + +var + frm2006Compatibility: Tfrm2006Compatibility; + +implementation + +{$R *.dfm} + +{ Tfrm2006Compatibility } + +constructor Tfrm2006Compatibility.CreateNew(AOwner: TComponent; Dummy: Integer); +begin + inherited CreateNew(AOwner, Dummy); +// - if Form is pulled up in Delphi 6, the value stored in the DFM will be erased + position := poDesigned; + AutoScroll := True; +end; + +end. Index: cprs/trunk/CPRS-Lib/ORCtrlLib2006.dpk =================================================================== --- cprs/trunk/CPRS-Lib/ORCtrlLib2006.dpk (revision 829) +++ cprs/trunk/CPRS-Lib/ORCtrlLib2006.dpk (revision 829) @@ -0,0 +1,41 @@ +package ORCtrlLib2006; + +{$R *.res} +{$R 'ORCtrlsDsgn.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS ON} +{$RANGECHECKS ON} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'CPRS Custom Controls'} +{$DESIGNONLY} +{$IMPLICITBUILD ON} + +requires + vcl, + vclx, + designide, + VAShared2006, + rtl; + +contains + ORCtrls in 'ORCtrls.pas', + ORCtrlsDsgn in 'ORCtrlsDsgn.pas'; + +end. Index: cprs/trunk/CPRS-Lib/ORCtrlLib2006.drc =================================================================== --- cprs/trunk/CPRS-Lib/ORCtrlLib2006.drc (revision 829) +++ cprs/trunk/CPRS-Lib/ORCtrlLib2006.drc (revision 829) @@ -0,0 +1,14 @@ +/* VER180 + Generated by the Borland Delphi Pascal Compiler + because -GD or --drc was supplied to the compiler. + + This file contains compiler-generated resources that + were bound to the executable. + If this file is empty, then no compiler-generated + resources were bound to the produced executable. +*/ + +STRINGTABLE +BEGIN +END + Index: cprs/trunk/CPRS-Lib/ORCtrls.pas =================================================================== --- cprs/trunk/CPRS-Lib/ORCtrls.pas (revision 456) +++ cprs/trunk/CPRS-Lib/ORCtrls.pas (revision 829) @@ -7,5 +7,5 @@ uses Windows, Messages, SysUtils, Classes, Graphics, Controls, StdCtrls, Forms, ComCtrls, Commctrl, Buttons, ExtCtrls, Grids, ImgList, Menus, CheckLst, - Accessibility_TLB, Variants; + Variants, VAClasses; const @@ -21,14 +21,7 @@ type - - TORStaticText = class(TStaticText) - private - FOnEnter: TNotifyEvent; - FOnExit: TNotifyEvent; - published - property OnEnter: TNotifyEvent read FOnEnter write FOnEnter; - property OnExit: TNotifyEvent read FOnExit write FOnExit; - procedure DoEnter; override; - procedure DoExit; override; + IORBlackColorModeCompatible = interface(IInterface) + ['{3554985C-F524-45FA-8C27-4CDD8357DB08}'] + procedure SetBlackColorMode(Value: boolean); end; @@ -81,5 +74,5 @@ end; - TORListBox = class(TListBox) + TORListBox = class(TListBox, IVADynamicProperty, IORBlackColorModeCompatible) private FFocusIndex: Integer; // item with focus when using navigation keys @@ -127,8 +120,9 @@ FMItems: TORStrings; // Used to save corresponding M strings ("the pieces") FCaption: TStaticText; // Used to supply a title to IAccessible interface - FAccessible: IAccessible; FCaseChanged: boolean; // If true, the names are stored in the database as all caps, but loaded and displayed in mixed-case 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 - procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT; + FIsPartOfComboBox: boolean; + FBlackColorMode: boolean; + FHideSelection: boolean; procedure AdjustScrollBar; procedure CreateScrollBar; @@ -214,4 +208,5 @@ procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override; function GetIndexFromY(YPos :integer) :integer; + property isPartOfComboBox: boolean read FIsPartOfComboBox write FIsPartOfComboBox default False; property HideSynonyms: boolean read FHideSynonyms write SetHideSynonyms default FALSE; property SynonymChars: string read FSynonymChars write SetSynonymChars; @@ -241,6 +236,9 @@ property CheckedState[Index: Integer]: TCheckBoxState read GetCheckedState write SetCheckedState; property MItems: TStrings read GetMItems write SetMItems; - procedure MakeAccessible(Accessible: IAccessible); function VerifyUnique(SelectIndex: Integer; iText: String): integer; + procedure SetBlackColorMode(Value: boolean); + function SupportsDynamicProperty(PropertyID: integer): boolean; + function GetDynamicProperty(PropertyID: integer): string; + property HideSelection: boolean read FHideSelection write FHideSelection; published property AllowGrayed: boolean read FAllowGrayed write FAllowGrayed default FALSE; @@ -303,5 +301,5 @@ end; - TORComboBox = class(TWinControl) + TORComboBox = class(TWinControl, IVADynamicProperty, IORBlackColorModeCompatible) private FItems: TStrings; // points to Items in FListBox @@ -340,4 +338,9 @@ FCharsNeedMatch: integer; // how many text need to be matched for auto selection FUniqueAutoComplete: Boolean; // If true only perform autocomplete for unique list items. + FBlackColorMode: boolean; + FDisableHints: boolean; // true if hints have been disabled because drop down window was opened + FDropDownStatusChangedCount: integer; // prevents multiple calls to disabling hint window + procedure DropDownStatusChanged(opened: boolean); + procedure ClearDropDownStatus; function EditControl: TWinControl; procedure AdjustSizeOfSelf; @@ -440,4 +443,5 @@ procedure SetLookupPiece(const Value: integer); procedure SetUniqueAutoComplete(const Value: Boolean); + procedure LoadComboBoxImage; protected procedure DropPanelBtnPressed(OKBtn, AutoClose: boolean); @@ -452,4 +456,5 @@ public constructor Create(AOwner: TComponent); override; + destructor Destroy; override; function AddReference(const S: string; AReference: Variant): Integer; procedure Clear; @@ -458,4 +463,5 @@ procedure InitLongList(S: string); procedure InsertSeparator; + procedure Invalidate; override; procedure SetTextAutoComplete(TextToMatch : String); function GetIEN(AnIndex: Integer): Int64; @@ -466,5 +472,7 @@ procedure InsertReference(Index: Integer; const S: string; AReference: Variant); procedure SelectAll; - function MakeAccessible( Accessible: IAccessible): TORListBox; + procedure SetBlackColorMode(Value: boolean); + function SupportsDynamicProperty(PropertyID: integer): boolean; + function GetDynamicProperty(PropertyID: integer): string; property DisplayText[Index: Integer]: string read GetDisplayText; property DroppedDown: Boolean read FDroppedDown write SetDroppedDown; @@ -648,5 +656,5 @@ - TCaptionTreeView = class(TTreeView) + TCaptionTreeView = class(TTreeView, IVADynamicProperty) private procedure SetCaption(const Value: string); @@ -654,4 +662,7 @@ protected FCaptionComponent: TStaticText; + public + function SupportsDynamicProperty(PropertyID: integer): boolean; + function GetDynamicProperty(PropertyID: integer): string; published property Align; @@ -665,7 +676,5 @@ FTag: integer; FStringData: string; - FAccessible: IAccessible; FCaption: string; - procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT; function GetParent: TORTreeNode; procedure SetCaption(const Value: string); @@ -679,8 +688,6 @@ function GetORTreeView: TORTreeView; public - procedure MakeAccessible(Accessible: IAccessible); procedure SetPiece(PieceNum: Integer; const NewPiece: string); procedure EnsureVisible; - property Accessible: IAccessible read FAccessible write MakeAccessible; property Bold: boolean read GetBold write SetBold; property Tag: integer read FTag write FTag; @@ -700,8 +707,6 @@ FPiece: integer; FOnAddition: TTVExpandedEvent; - FAccessible: IAccessible; FShortNodeCaptions: boolean; FOnNodeCaptioning: TNodeCaptioningEvent; - procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT; procedure SetShortNodeCaptions(const Value: boolean); protected @@ -716,5 +721,4 @@ public constructor Create(AOwner: TComponent); override; - procedure MakeAccessible(Accessible: IAccessible); function FindPieceNode(Value: string; ParentDelim: Char = #0; StartNode: TTreeNode = nil): TORTreeNode; overload; @@ -776,5 +780,5 @@ TGrayedStyle = (gsNormal, gsQuestionMark, gsBlueQuestionMark); - TORCheckBox = class(TCheckBox) + TORCheckBox = class(TCheckBox, IORBlackColorModeCompatible) private FStringData: string; @@ -793,4 +797,5 @@ FAssociate: TControl; FFocusOnBox: boolean; + FBlackColorMode: boolean; procedure SetFocusOnBox(value: boolean); procedure CNMeasureItem (var Message: TWMMeasureItem); message CN_MEASUREITEM; @@ -835,4 +840,5 @@ destructor Destroy; override; procedure AutoAdjustSize; + procedure SetBlackColorMode(Value: boolean); property SingleLine: boolean read FSingleLine; property StringData: string read FStringData write FStringData; @@ -899,20 +905,22 @@ end; - TCaptionListBox = class(TListBox) + TCaptionListBox = class(TListBox, IVADynamicProperty) private FHoverItemPos: integer; - FAccessible: IAccessible; FRightClickSelect: boolean; // When true, a right click selects teh item FHintOnItem: boolean; procedure SetCaption(const Value: string); function GetCaption: string; - procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT; procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP; procedure WMMouseMove(var Message: TWMMouseMove); message WM_MOUSEMOVE; + procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN; + procedure MoveFocusDown; + procedure MoveFocusUp; protected FCaptionComponent: TStaticText; procedure DoEnter; override; public - procedure MakeAccessible( Accessible: IAccessible); + function SupportsDynamicProperty(PropertyID: integer): boolean; + function GetDynamicProperty(PropertyID: integer): string; published property RightClickSelect: boolean read FRightClickSelect write FRightClickSelect default FALSE; @@ -922,5 +930,5 @@ end; - TCaptionCheckListBox = class(TCheckListBox) + TCaptionCheckListBox = class(TCheckListBox, IVADynamicProperty) private procedure SetCaption(const Value: string); @@ -928,9 +936,12 @@ protected FCaptionComponent: TStaticText; + public + function SupportsDynamicProperty(PropertyID: integer): boolean; + function GetDynamicProperty(PropertyID: integer): string; published property Caption: string read GetCaption write SetCaption; end; - TCaptionMemo = class(TMemo) + TCaptionMemo = class(TMemo, IVADynamicProperty) private procedure SetCaption(const Value: string); @@ -938,9 +949,12 @@ protected FCaptionComponent: TStaticText; + public + function SupportsDynamicProperty(PropertyID: integer): boolean; + function GetDynamicProperty(PropertyID: integer): string; published property Caption: string read GetCaption write SetCaption; end; - TCaptionEdit = class(TEdit) + TCaptionEdit = class(TEdit, IVADynamicProperty) private procedure SetCaption(const Value: string); @@ -948,4 +962,7 @@ protected FCaptionComponent: TStaticText; + public + function SupportsDynamicProperty(PropertyID: integer): boolean; + function GetDynamicProperty(PropertyID: integer): string; published property Align; @@ -953,12 +970,11 @@ end; - TCaptionRichEdit = class(TRichEdit) + TCaptionRichEdit = class(TRichEdit, IVADynamicProperty) private - FAccessible: IAccessible; - procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT; protected FCaption: string; public - procedure MakeAccessible(Accessible: IAccessible); + function SupportsDynamicProperty(PropertyID: integer): boolean; + function GetDynamicProperty(PropertyID: integer): string; published property Align; @@ -966,5 +982,5 @@ end; - TCaptionComboBox = class(TComboBox) + TCaptionComboBox = class(TComboBox, IVADynamicProperty) private procedure SetCaption(const Value: string); @@ -972,25 +988,30 @@ protected FCaptionComponent: TStaticText; + public + function SupportsDynamicProperty(PropertyID: integer): boolean; + function GetDynamicProperty(PropertyID: integer): string; published property Caption: string read GetCaption write SetCaption; end; - TCaptionListView = class(TListView) + TCaptionListView = class(TListView, IVADynamicProperty) + public + function SupportsDynamicProperty(PropertyID: integer): boolean; + function GetDynamicProperty(PropertyID: integer): string; published property Caption; end; - TCaptionStringGrid = class(TStringGrid) + TCaptionStringGrid = class(TStringGrid, IVADynamicProperty) private FJustToTab: boolean; FCaption: string; - FAccessible: IAccessible; - procedure WMGetObject(var Message: TMessage); message WM_GETOBJECT; protected procedure KeyUp(var Key: Word; Shift: TShiftState); override; public - procedure MakeAccessible( Accessible: IAccessible); procedure IndexToColRow( index: integer; var Col: integer; var Row: integer); function ColRowToIndex( Col: integer; Row: Integer): integer; + function SupportsDynamicProperty(PropertyID: integer): boolean; + function GetDynamicProperty(PropertyID: integer): string; published property Caption: string read FCaption write FCaption; @@ -1015,5 +1036,5 @@ uses - uAccessAPI; + VAUtils; const @@ -1424,15 +1445,30 @@ 'ORCB_RADIO_DISABLED_UNCHECKED', 'ORCB_RADIO_DISABLED_CHECKED'); -var - ORCBImages: array[TORCBImgIdx] of TBitMap; - -function GetORCBBitmap(Idx: TORCBImgIdx): TBitmap; -begin - if(not assigned(ORCBImages[Idx])) then - begin - ORCBImages[Idx] := TBitMap.Create; - ORCBImages[Idx].LoadFromResourceName(HInstance, CheckBoxImageResNames[Idx]); - end; - Result := ORCBImages[Idx]; + BlackCheckBoxImageResNames: array[TORCBImgIdx] of PChar = ( + 'BLACK_ORLB_FLAT_UNCHECKED', 'BLACK_ORLB_FLAT_CHECKED', 'BLACK_ORLB_FLAT_GRAYED', + 'BLACK_ORCB_QUESTIONMARK', 'BLACK_ORCB_BLUEQUESTIONMARK', + 'BLACK_ORCB_DISABLED_UNCHECKED', 'BLACK_ORCB_DISABLED_CHECKED', + 'BLACK_ORCB_DISABLED_GRAYED', 'BLACK_ORCB_DISABLED_QUESTIONMARK', + 'BLACK_ORLB_FLAT_UNCHECKED', 'BLACK_ORLB_FLAT_CHECKED', 'BLACK_ORLB_FLAT_GRAYED', + 'BLACK_ORCB_RADIO_UNCHECKED', 'BLACK_ORCB_RADIO_CHECKED', + 'BLACK_ORCB_RADIO_DISABLED_UNCHECKED', 'BLACK_ORCB_RADIO_DISABLED_CHECKED'); + +var + ORCBImages: array[TORCBImgIdx, Boolean] of TBitMap; + +function GetORCBBitmap(Idx: TORCBImgIdx; BlackMode: boolean): TBitmap; +var + ResName: string; +begin + if(not assigned(ORCBImages[Idx, BlackMode])) then + begin + ORCBImages[Idx, BlackMode] := TBitMap.Create; + if BlackMode then + ResName := BlackCheckBoxImageResNames[Idx] + else + ResName := CheckBoxImageResNames[Idx]; + ORCBImages[Idx, BlackMode].LoadFromResourceName(HInstance, ResName); + end; + Result := ORCBImages[Idx, BlackMode]; end; @@ -1440,27 +1476,15 @@ var i: TORCBImgIdx; + mode: boolean; begin for i := low(TORCBImgIdx) to high(TORCBImgIdx) do begin - if(assigned(ORCBImages[i])) then - ORCBImages[i].Free; - end; -end; - -{ TORStaticText } - -procedure TORStaticText.DoEnter; -begin - inherited DoEnter; - if Assigned(FOnEnter) then - FOnEnter(Self); -end; - -procedure TORStaticText.DoExit; -begin - inherited DoExit; - if Assigned(FOnExit) then - FOnExit(Self); + for Mode := false to true do + begin + if(assigned(ORCBImages[i, Mode])) then + ORCBImages[i, Mode].Free; + end; + end; end; @@ -1658,4 +1682,5 @@ FCaseChanged := TRUE; FLookupPiece := 0; + FIsPartOfComboBox := False; end; @@ -1768,4 +1793,12 @@ SetString(Result, Buf, Len); end; +end; + +function TORListBox.GetDynamicProperty(PropertyID: integer): string; +begin + if PropertyID = DynaPropAccesibilityCaption then + Result := GetCaption + else + Result := ''; end; @@ -2016,23 +2049,27 @@ case Message.CharCode of VK_LBUTTON, VK_RETURN, VK_SPACE: - if FocusIndex > -1 then - begin - if MultiSelect then + begin + if (FocusIndex < 0) and (CheckBoxes or MultiSelect) and (Count > 0) then // JNM - 508 compliance + SetFocusIndex(0); + if FocusIndex > -1 then begin - IsSelected := LongBool(Perform(LB_GETSEL, FocusIndex, 0)); - Perform(LB_SETSEL, Longint(not IsSelected), FocusIndex); - end - else Perform(LB_SETCURSEL, FocusIndex, 0); - // Send WM_COMMAND here because LBN_SELCHANGE not triggered by LB_SETSEL - // and LBN_SELCHANGE is what eventually triggers the Click event. - // The LBN_SELCHANGE documentation implies we should send the control id, which is - // 32 bits long, in the high word of WPARAM (16 bits). Since that won't work - we'll - // try sending the item index instead. - //PostMessage() not SendMessage() is Required here for checkboxes, SendMessage() doesn't - //Allow the Checkbox state on the control to be updated - if CheckBoxes then - PostMessage(Parent.Handle, WM_COMMAND, MAKELONG(FocusIndex, LBN_SELCHANGE), LPARAM(Handle)) - else - SendMessage(Parent.Handle, WM_COMMAND, MAKELONG(FocusIndex, LBN_SELCHANGE), LPARAM(Handle)); + if MultiSelect then + begin + IsSelected := LongBool(Perform(LB_GETSEL, FocusIndex, 0)); + Perform(LB_SETSEL, Longint(not IsSelected), FocusIndex); + end + else Perform(LB_SETCURSEL, FocusIndex, 0); + // Send WM_COMMAND here because LBN_SELCHANGE not triggered by LB_SETSEL + // and LBN_SELCHANGE is what eventually triggers the Click event. + // The LBN_SELCHANGE documentation implies we should send the control id, which is + // 32 bits long, in the high word of WPARAM (16 bits). Since that won't work - we'll + // try sending the item index instead. + //PostMessage() not SendMessage() is Required here for checkboxes, SendMessage() doesn't + //Allow the Checkbox state on the control to be updated + if CheckBoxes then + PostMessage(Parent.Handle, WM_COMMAND, MAKELONG(FocusIndex, LBN_SELCHANGE), LPARAM(Handle)) + else + SendMessage(Parent.Handle, WM_COMMAND, MAKELONG(FocusIndex, LBN_SELCHANGE), LPARAM(Handle)); + end; end; VK_PRIOR: SetFocusIndex(FocusIndex - FLargeChange); @@ -2236,4 +2273,6 @@ begin FLastItemIndex := ItemIndex; + if (not isPartOfComboBox) and (ItemIndex <> -1) then + SetFocusIndex(ItemIndex); if Assigned(FOnChange) then FOnChange(Self); end; @@ -2248,10 +2287,21 @@ { if (Items.Count > 0) and (Not IsAMouseButtonDown()) and (ItemIndex = -1) then SetFocusIndex(TopIndex);//ItemIndex := TopIndex; } + if FHideSelection and (ItemIndex < 0) and (FFocusIndex >= 0) then + ItemIndex := FFocusIndex; inherited DoEnter; end; procedure TORListBox.DoExit; +var + SaveIndex: integer; { make sure item tip is hidden for this listbox when focus shifts to something else } begin + if FHideSelection then + begin + SaveIndex := ItemIndex; + ItemIndex := -1; + FFocusIndex := SaveIndex; + end; + uItemTip.Hide; FItemTipActive := False; @@ -2321,6 +2371,12 @@ procedure TORListBox.KeyPress(var Key: Char); begin + {inherited KeyPress is changing the ' ' into #0, had to move conditional before inherited.} + if (Key = ' ') then begin + ToggleCheckBox(ItemIndex); + {The space bar causes the focus to jump to an item in the list that starts with + a space. Disable that function.} + Key := #0; + end; inherited; - if (Key = ' ') then ToggleCheckBox(ItemIndex); end; @@ -2459,21 +2515,21 @@ begin if(FFlatCheckBoxes) then - BMap := GetORCBBitmap(iiFlatUnChecked) + BMap := GetORCBBitmap(iiFlatUnChecked, FBlackColorMode) else - BMap := GetORCBBitmap(iiUnchecked); + BMap := GetORCBBitmap(iiUnchecked, FBlackColorMode); end; cbChecked: begin if(FFlatCheckBoxes) then - BMap := GetORCBBitmap(iiFlatChecked) + BMap := GetORCBBitmap(iiFlatChecked, FBlackColorMode) else - BMap := GetORCBBitmap(iiChecked); + BMap := GetORCBBitmap(iiChecked, FBlackColorMode); end; else // cbGrayed: begin if(FFlatCheckBoxes) then - BMap := GetORCBBitmap(iiFlatGrayed) + BMap := GetORCBBitmap(iiFlatGrayed, FBlackColorMode) else - BMap := GetORCBBitmap(iiGrayed); + BMap := GetORCBBitmap(iiGrayed, FBlackColorMode); end; end; @@ -2482,7 +2538,7 @@ begin if(FFlatCheckBoxes) then - BMap := GetORCBBitmap(iiFlatGrayed) + BMap := GetORCBBitmap(iiFlatGrayed, FBlackColorMode) else - BMap := GetORCBBitmap(iiGrayed); + BMap := GetORCBBitmap(iiGrayed, FBlackColorMode); end; TmpR := Rect; @@ -2584,8 +2640,9 @@ end; end; // -- special long list processing - end + if (Value = SFI_END) or (not (Value < Items.Count)) then Value := Items.Count - 1; if (Value = SFI_TOP) or (Value < 0) then Value := 0; - if (Value = SFI_END) or (not (Value < Items.Count)) then Value := Items.Count - 1; FFocusIndex := Value; - ItemIndex := Value; + if Focused or (not FHideSelection) then + ItemIndex := Value; if MultiSelect then Perform(LB_SETCARETINDEX, FFocusIndex, 0) // LPARAM=0, scrolls into view else @@ -2850,4 +2907,9 @@ end; +function TORListBox.SupportsDynamicProperty(PropertyID: integer): boolean; +begin + Result := (PropertyID = DynaPropAccesibilityCaption); +end; + procedure TORListBox.SetHideSynonyms(Value :boolean); var @@ -2930,5 +2992,5 @@ Strings: TStringList; i, Pos: Integer; - ItemRec: PItemRec; + ItemRec, ItemRec2: PItemRec; SaveListMode: Boolean; RealVerify: Boolean; @@ -2960,5 +3022,13 @@ begin Pos := Items.AddObject(Strings[i], ItemRec^.UserObject); - References[Pos] := ItemRec^.Reference; + // CQ 11491 - Changing TabPositions, etc. was wiping out check box status. + FFromSelf := True; + ItemRec2 := PItemRec(SendMessage(Handle,LB_GETITEMDATA, Pos, 0)); + FFromSelf := False; + if(assigned(ItemRec2)) then + begin + ItemRec2^.Reference := ItemRec^.Reference; + ItemRec2^.CheckedState := ItemRec^.CheckedState; + end; end; end; @@ -3505,4 +3575,9 @@ end; +procedure TORListBox.SetBlackColorMode(Value: boolean); +begin + FBlackColorMode := Value; +end; + procedure TORListBox.SetCaption(const Value: string); begin @@ -3527,18 +3602,29 @@ end; -procedure TORListBox.MakeAccessible(Accessible: IAccessible); -begin - if Assigned(FAccessible) and Assigned(Accessible) then - raise Exception.Create(Caption + ' List Box is already Accessible!') - else - FAccessible := Accessible; -end; - -procedure TORListBox.WMGetObject(var Message: TMessage); -begin - if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then - Message.Result := GetLResult(Message.wParam, FAccessible) - else - inherited; +// In Delphi 2006, hint windows will cause the TORComboBox drop down list to +// move behind a Stay on Top form. Hints are also problematic with item tips in +// the drop down list, so we disable them when ever a drop down list is open, +// on all forms, not just stay on top forms. +var + uDropPanelOpenCount: integer = 0; + uOldShowHintsSetting: boolean; + +procedure DropDownPanelOpened; +begin + if uDropPanelOpenCount=0 then + uOldShowHintsSetting := Application.ShowHint; + Application.ShowHint := FALSE; + inc(uDropPanelOpenCount); +end; + +procedure DropDownPanelClosed; +begin + dec(uDropPanelOpenCount); + if uDropPanelOpenCount<=0 then + begin + uDropPanelOpenCount := 0; + if not Application.ShowHint then + Application.ShowHint := uOldShowHintsSetting + end; end; @@ -3690,5 +3776,6 @@ const ComboBoxImages: array[boolean] of string = ('BMP_CBODOWN_DISABLED', 'BMP_CBODOWN'); - + BlackComboBoxImages: array[boolean] of string = ('BLACK_BMP_CBODOWN_DISABLED', 'BLACK_BMP_CBODOWN'); + procedure TORComboEdit.CreateParams(var Params: TCreateParams); { sets a one line edit box to multiline style so the editing rectangle can be changed } @@ -3740,4 +3827,5 @@ FCheckBoxEditColor := clBtnFace; FListBox := TORListBox.Create(Self); + FListBox.isPartOfComboBox := True; FListBox.Parent := Self; FListBox.TabStop := False; @@ -3866,4 +3954,45 @@ end; +procedure TORComboBox.DropDownStatusChanged(opened: boolean); +begin + if opened then + begin + if not FDropPanel.Visible then + begin + if FDropDownStatusChangedCount = 0 then + begin + FDisableHints := TRUE; + DropDownPanelOpened; + end; + inc(FDropDownStatusChangedCount); + end; + end + else + begin + dec(FDropDownStatusChangedCount); + if FDropDownStatusChangedCount <= 0 then + begin + if FDisableHints then + begin + DropDownPanelClosed; + FDisableHints := FALSE; + end; + FDropDownStatusChangedCount := 0; + end; + end; +end; + +procedure TORComboBox.ClearDropDownStatus; +begin + FDropDownStatusChangedCount := 1; + DropDownStatusChanged(FALSE); +end; + +destructor TORComboBox.Destroy; +begin + ClearDropDownStatus; + inherited; +end; + procedure TORComboBox.DoEnter; {var @@ -3902,4 +4031,18 @@ end; inherited DoExit; +end; + +procedure TORComboBox.LoadComboBoxImage; +var + imageName: string; +begin + if assigned(FDropBtn) then + begin + if FBlackColorMode then + imageName := BlackComboBoxImages[inherited Enabled] + else + imageName := ComboBoxImages[inherited Enabled]; + FDropBtn.Glyph.LoadFromResourceName(hInstance, imageName); + end; end; @@ -4098,13 +4241,24 @@ procedure TORComboBox.FwdKeyPress(Sender: TObject; var Key: Char); +var + KeyCode: integer; { prevents return from being used by editbox (otherwise sends a newline & text vanishes) } begin - // may want to make the tab beep if tab key (#9) - can't tab until list raised - if (Key in [#9, #13]) or (FListBox.FCheckBoxes and (Key = #32)) then - begin + KeyCode := ord(Key); + if (KeyCode = VK_RETURN) and (Style = orcsDropDown) and DroppedDown then + begin + DroppedDown := FALSE; Key := #0; - Exit; - end; - if Assigned(FOnKeyPress) then FOnKeyPress(Self, Key); + end + else + begin + // may want to make the tab beep if tab key (#9) - can't tab until list raised + if (KeyCode = VK_RETURN) or (KeyCode = VK_TAB) or (FListBox.FCheckBoxes and (KeyCode = VK_SPACE)) then + begin + Key := #0; + Exit; + end; + if Assigned(FOnKeyPress) then FOnKeyPress(Self, Key); + end; end; @@ -4168,4 +4322,5 @@ FCheckedState := FListBox.GetCheckedString; end; + DropDownStatusChanged(TRUE); FDropPanel.Visible := True; FDropPanel.BringToFront; @@ -4178,4 +4333,5 @@ uItemTip.Hide; FDropPanel.Hide; + DropDownStatusChanged(FALSE); if(FListBox.FCheckBoxes) and (assigned(FOnChange)) and (FCheckedState <> FListBox.GetCheckedString) then @@ -4265,5 +4421,9 @@ begin if FDropBtn <> nil then FDropBtn.Free; - if FDropPanel <> nil then FDropPanel.Free; + if FDropPanel <> nil then + begin + ClearDropDownStatus; + FDropPanel.Free; + end; FDropBtn := nil; FDropPanel := nil; @@ -4280,5 +4440,6 @@ if(assigned(FEditPanel) and (csDesigning in ComponentState)) then FEditPanel.ControlStyle := FEditPanel.ControlStyle - [csAcceptsControls]; - FDropBtn.Glyph.LoadFromResourceName(hInstance, ComboBoxImages[inherited Enabled]); + LoadComboBoxImage; +// FDropBtn.Glyph.LoadFromResourceName(hInstance, ComboBoxImages[inherited Enabled]); FDropBtn.OnMouseDown := DropButtonDown; FDropBtn.OnMouseUp := DropButtonUp; @@ -4292,4 +4453,5 @@ FListBox.FParentCombo := Self; FListBox.Parent := FDropPanel; + ClearDropDownStatus; if FListBox.FScrollBar <> nil then FListBox.FScrollBar.Parent := FDropPanel; // if long end else @@ -4328,4 +4490,9 @@ end; +function TORComboBox.SupportsDynamicProperty(PropertyID: integer): boolean; +begin + Result := (PropertyID = DynaPropAccesibilityCaption); +end; + // Since TORComboBox is composed of several controls (FEditBox, FListBox, FDropBtn), the // following functions and procedures map public and published properties to their related @@ -4373,4 +4540,17 @@ end; +procedure TORComboBox.Invalidate; +begin + inherited; + FEditBox.Invalidate; + FListBox.Invalidate; + if assigned(FEditPanel) then + FEditPanel.Invalidate; + if assigned(FDropBtn) then + FDropBtn.Invalidate; + if assigned(FDropPanel) then + FDropPanel.Invalidate; +end; + function TORComboBox.GetAutoSelect: Boolean; begin @@ -4393,4 +4573,12 @@ end; +function TORComboBox.GetDynamicProperty(PropertyID: integer): string; +begin + if PropertyID = DynaPropAccesibilityCaption then + Result := GetCaption + else + Result := ''; +end; + function TORComboBox.GetItemHeight: Integer; begin @@ -4516,4 +4704,14 @@ begin FEditBox.AutoSelect := Value; +end; + +procedure TORComboBox.SetBlackColorMode(Value: boolean); +begin + if FBlackColorMode <> Value then + begin + FBlackColorMode := Value; + FListBox.SetBlackColorMode(Value); + LoadComboBoxImage; + end; end; @@ -4774,7 +4972,9 @@ if (inherited GetEnabled <> Value) then begin + DroppedDown := FALSE; inherited SetEnabled(Value); if assigned(FDropBtn) then - FDropBtn.Glyph.LoadFromResourceName(hInstance, ComboBoxImages[Value]); + LoadComboBoxImage; +// FDropBtn.Glyph.LoadFromResourceName(hInstance, ComboBoxImages[Value]); end; end; @@ -4837,10 +5037,4 @@ begin result := FListBox.Caption; -end; - -function TORComboBox.MakeAccessible(Accessible: IAccessible): TORListBox; -begin - FListBox.MakeAccessible(Accessible); - result := FListBox; end; @@ -5261,22 +5455,4 @@ ORCtrls.SetPiece(FStringData, FDelim, FPiece, Value); end; -end; - -procedure TORTreeNode.MakeAccessible(Accessible: IAccessible); -begin - if Assigned(FAccessible) and Assigned(Accessible) then - raise Exception.Create(Text + ' Tree Node is already Accessible!') - else - begin - FAccessible := Accessible; - end; -end; - -procedure TORTreeNode.WMGetObject(var Message: TMessage); -begin - if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then - Message.Result := GetLResult(Message.wParam, FAccessible) - else - inherited; end; @@ -5522,22 +5698,4 @@ else Result := ''; -end; - -procedure TORTreeView.MakeAccessible(Accessible: IAccessible); -begin - if Assigned(FAccessible) and Assigned(Accessible) then - raise Exception.Create(Text + ' Tree View is already Accessible!') - else - begin - FAccessible := Accessible; - end; -end; - -procedure TORTreeView.WMGetObject(var Message: TMessage); -begin - if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then - Message.Result := GetLResult(Message.wParam, FAccessible) - else - inherited; end; @@ -5908,5 +6066,5 @@ end; end; - Bitmap := GetORCBBitmap(ImgIdx); + Bitmap := GetORCBBitmap(ImgIdx, FBlackColorMode); end else @@ -6050,6 +6208,8 @@ R.Top:= FocusRect.Top else + begin R.Top:= ((ClientHeight - Bitmap.Height + 1) div 2) - 1; - + if R.Top < 0 then R.Top := 0 + end; Draw(R.Left, R.Top, Bitmap); end; @@ -6145,4 +6305,13 @@ end; +procedure TORCheckBox.SetBlackColorMode(Value: boolean); +begin + if FBlackColorMode <> Value then + begin + FBlackColorMode := Value; + Invalidate; + end; +end; + procedure TORCheckBox.AutoAdjustSize; var @@ -6276,5 +6445,11 @@ if DoCtrl then Ctrl.Enabled := Checked; - if(Ctrl is TWinControl) then + + // added (csAcceptsControls in Ctrl.ControlStyle) below to prevent disabling of + // child sub controls, like the TBitBtn in the TORComboBox. If the combo box is + // already disabled, we don't want to disable the button as well - when we do, we + // lose the disabled glyph that is stored on that button for the combo box. + + if(Ctrl is TWinControl) and (csAcceptsControls in Ctrl.ControlStyle) then begin for i := 0 to TWinControl(Ctrl).ControlCount-1 do @@ -6500,10 +6675,23 @@ end; -procedure TCaptionListBox.MakeAccessible(Accessible: IAccessible); -begin - if Assigned(FAccessible) and Assigned(Accessible) then - raise Exception.Create(Caption + ' List Box is already Accessible!') +function TCaptionListBox.GetDynamicProperty(PropertyID: integer): string; +begin + if PropertyID = DynaPropAccesibilityCaption then + Result := GetCaption else - FAccessible := Accessible; + Result := ''; +end; + + +procedure TCaptionListBox.MoveFocusUp; +begin + if ItemIndex > 0 then + Perform(LB_SETCARETINDEX, ItemIndex - 1, 0); +end; + +procedure TCaptionListBox.MoveFocusDown; +begin + if ItemIndex < (Items.Count-1) then + Perform(LB_SETCARETINDEX, ItemIndex + 1, 0); end; @@ -6522,10 +6710,25 @@ end; -procedure TCaptionListBox.WMGetObject(var Message: TMessage); -begin - if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then - Message.Result := GetLResult(Message.wParam, FAccessible) - else - inherited; +function TCaptionListBox.SupportsDynamicProperty(PropertyID: integer): boolean; +begin + Result := (PropertyID = DynaPropAccesibilityCaption); +end; + +procedure TCaptionListBox.WMKeyDown(var Message: TWMKeyDown); +var + IsSelected: LongBool; +begin + if Boolean(Hi(GetKeyState(VK_CONTROL))) and MultiSelect then + case Message.CharCode of + VK_SPACE: + begin + IsSelected := LongBool(Perform(LB_GETSEL, ItemIndex, 0)); + Perform(LB_SETSEL, Longint(not IsSelected), ItemIndex); + end; + VK_LEFT, VK_UP: MoveFocusUp; + VK_RIGHT, VK_DOWN: MoveFocusDown; + else inherited; + end + else inherited; end; @@ -6591,4 +6794,12 @@ end; +function TCaptionCheckListBox.GetDynamicProperty(PropertyID: integer): string; +begin + if PropertyID = DynaPropAccesibilityCaption then + Result := GetCaption + else + Result := ''; +end; + procedure TCaptionCheckListBox.SetCaption(const Value: string); begin @@ -6605,4 +6816,10 @@ end; +function TCaptionCheckListBox.SupportsDynamicProperty( + PropertyID: integer): boolean; +begin + Result := (PropertyID = DynaPropAccesibilityCaption); +end; + { TCaptionMemo } @@ -6613,4 +6830,12 @@ else result := FCaptionComponent.Caption; +end; + +function TCaptionMemo.GetDynamicProperty(PropertyID: integer): string; +begin + if PropertyID = DynaPropAccesibilityCaption then + Result := GetCaption + else + Result := ''; end; @@ -6629,4 +6854,9 @@ end; +function TCaptionMemo.SupportsDynamicProperty(PropertyID: integer): boolean; +begin + Result := (PropertyID = DynaPropAccesibilityCaption); +end; + { TCaptionEdit } @@ -6637,4 +6867,12 @@ else result := FCaptionComponent.Caption; +end; + +function TCaptionEdit.GetDynamicProperty(PropertyID: integer): string; +begin + if PropertyID = DynaPropAccesibilityCaption then + Result := GetCaption + else + Result := ''; end; @@ -6653,27 +6891,38 @@ end; +function TCaptionEdit.SupportsDynamicProperty(PropertyID: integer): boolean; +begin + Result := (PropertyID = DynaPropAccesibilityCaption); +end; + { TCaptionRichEdit } -procedure TCaptionRichEdit.MakeAccessible(Accessible: IAccessible); -begin - if Assigned(FAccessible) and Assigned(Accessible) then - raise Exception.Create(Caption + ' Rich Edit is already Accessible!') +function TCaptionRichEdit.GetDynamicProperty(PropertyID: integer): string; +begin + if PropertyID = DynaPropAccesibilityCaption then + Result := FCaption else - FAccessible := Accessible; -end; - -procedure TCaptionRichEdit.WMGetObject(var Message: TMessage); -begin - if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then - Message.Result := GetLResult(Message.wParam, FAccessible) + Result := ''; +end; + + +function TCaptionRichEdit.SupportsDynamicProperty(PropertyID: integer): boolean; +begin + Result := (PropertyID = DynaPropAccesibilityCaption); +end; + +{ TCaptionTreeView} + +function TCaptionTreeView.GetCaption: string; +begin + result := inherited Caption; +end; + +function TCaptionTreeView.GetDynamicProperty(PropertyID: integer): string; +begin + if PropertyID = DynaPropAccesibilityCaption then + Result := GetCaption else - inherited; -end; - -{ TCaptionTreeView} - -function TCaptionTreeView.GetCaption: string; -begin - result := inherited Caption; + Result := ''; end; @@ -6693,4 +6942,9 @@ end; +function TCaptionTreeView.SupportsDynamicProperty(PropertyID: integer): boolean; +begin + Result := (PropertyID = DynaPropAccesibilityCaption); +end; + { TCaptionComboBox } @@ -6701,4 +6955,12 @@ else result := FCaptionComponent.Caption; +end; + +function TCaptionComboBox.GetDynamicProperty(PropertyID: integer): string; +begin + if PropertyID = DynaPropAccesibilityCaption then + Result := GetCaption + else + Result := ''; end; @@ -6717,4 +6979,9 @@ end; +function TCaptionComboBox.SupportsDynamicProperty(PropertyID: integer): boolean; +begin + Result := (PropertyID = DynaPropAccesibilityCaption); +end; + { TORAlignSpeedButton } @@ -6742,4 +7009,12 @@ result := (ColCount - FixedCols) * (Row - FixedRows) + (Col - FixedCols) + 1; +end; + +function TCaptionStringGrid.GetDynamicProperty(PropertyID: integer): string; +begin + if PropertyID = DynaPropAccesibilityCaption then + Result := FCaption + else + Result := ''; end; @@ -6761,18 +7036,9 @@ end; -procedure TCaptionStringGrid.MakeAccessible(Accessible: IAccessible); -begin - if Assigned(FAccessible) and Assigned(Accessible) then - raise Exception.Create(Caption + 'String Grid is already Accessible!') - else - FAccessible := Accessible; -end; - -procedure TCaptionStringGrid.WMGetObject(var Message: TMessage); -begin - if (Message.LParam = integer(OBJID_CLIENT)) and Assigned(FAccessible) then - Message.Result := GetLResult(Message.wParam, FAccessible) - else - inherited; + +function TCaptionStringGrid.SupportsDynamicProperty( + PropertyID: integer): boolean; +begin + Result := (PropertyID = DynaPropAccesibilityCaption); end; @@ -6810,7 +7076,8 @@ if LongList then begin - //Currently Do nothing for LongLists - { if CompareText(iText, Copy(DisplayText[SelectIndex+1], 1, Length(iText))) = 0 then - Result := -1;} + //Implemented for CQ: 10092, PSI-04-057 + //asume long lists are alphabetically ordered... + if CompareText(iText, Copy(DisplayText[SelectIndex+1], 1, Length(iText))) = 0 then + Result := -1; end else //Not a LongList @@ -6836,4 +7103,19 @@ end; +{ TCaptionListView } + +function TCaptionListView.GetDynamicProperty(PropertyID: integer): string; +begin + if PropertyID = DynaPropAccesibilityCaption then + Result := Caption + else + Result := ''; +end; + +function TCaptionListView.SupportsDynamicProperty(PropertyID: integer): boolean; +begin + Result := (PropertyID = DynaPropAccesibilityCaption); +end; + initialization //uItemTip := TItemTip.Create(Application); // all listboxes share a single ItemTip window Index: cprs/trunk/CPRS-Lib/ORCtrlsDsgn.pas =================================================================== --- cprs/trunk/CPRS-Lib/ORCtrlsDsgn.pas (revision 456) +++ cprs/trunk/CPRS-Lib/ORCtrlsDsgn.pas (revision 829) @@ -153,5 +153,5 @@ begin RegisterComponents('CPRS', - [TORStaticText, TORListBox, TORComboBox, TORAutoPanel, TOROffsetLabel, TORAlignEdit, + [TORListBox, TORComboBox, TORAutoPanel, TOROffsetLabel, TORAlignEdit, TORAlignButton, TORAlignSpeedButton, TORTreeView, TORCheckBox, TORListView, TKeyClickPanel, TKeyClickRadioGroup, TCaptionListBox, TCaptionCheckListBox, Index: cprs/trunk/CPRS-Lib/ORCtrlsVA508Compatibility.pas =================================================================== --- cprs/trunk/CPRS-Lib/ORCtrlsVA508Compatibility.pas (revision 829) +++ cprs/trunk/CPRS-Lib/ORCtrlsVA508Compatibility.pas (revision 829) @@ -0,0 +1,618 @@ +unit ORCtrlsVA508Compatibility; + +interface + +uses + Forms, Controls, StdCtrls, SysUtils, Windows, VA508AccessibilityManager; + +type + TORCheckBox508Manager = class(TVA508ManagedComponentClass) + public + constructor Create; override; + function GetComponentName(Component: TWinControl): string; override; + function GetInstructions(Component: TWinControl): string; override; + function GetState(Component: TWinControl): string; override; + end; + + TLBMgr = class + private + function GetIdx(Component: TWinControl): integer; + public + function GetComponentName(Component: TWinControl): string; virtual; abstract; + function GetState(Component: TWinControl): string; virtual; abstract; + function GetItemInstructions(Component: TWinControl): string; virtual; abstract; + end; + + TORListBox508Manager = class(TVA508ManagedComponentClass) + var + FCheckBoxes: TLBMgr; + FMultiSelect: TLBMgr; + FStandard: TLBMgr; + FCurrent: TLBMgr; + function GetCurrent(Component: TWinControl): TLBMgr; + public + constructor Create; override; + destructor Destroy; override; + function GetComponentName(Component: TWinControl): string; override; + function GetState(Component: TWinControl): string; override; + function GetItem(Component: TWinControl): TObject; override; + function GetItemInstructions(Component: TWinControl): string; override; + function GetValue(Component: TWinControl): string; override; + end; + + TVA508TORDateComboComplexManager = class(TVA508ComplexComponentManager) + public + constructor Create; + procedure Refresh(Component: TWinControl; + AccessibilityManager: TVA508AccessibilityManager); override; + end; + +// TVA508TORComboBoxComplexManager = class(TVA508ComplexComponentManager) +// public +// constructor Create; +// procedure Refresh(Component: TWinControl; +// AccessibilityManager: TVA508AccessibilityManager); override; +// end; + +{ TVA508TORDateBoxComplexManager = class(TVA508ComplexComponentManager) + public + constructor Create; + procedure Refresh(Component: TWinControl; + AccessibilityManager: TVA508AccessibilityManager); override; + end;} + + TORComboBox508Manager = class(TVA508ManagedComponentClass) + public + constructor Create; override; + function GetValue(Component: TWinControl): string; override; + end; + + TORDayCombo508Manager = class(TORComboBox508Manager) + public + constructor Create; override; + function GetCaption(Component: TWinControl): string; override; + end; + + TORMonthCombo508Manager = class(TORComboBox508Manager) + public + constructor Create; override; + function GetCaption(Component: TWinControl): string; override; + end; + + TORYearEdit508Manager = class(TVA508ManagedComponentClass) + public + constructor Create; override; + function GetCaption(Component: TWinControl): string; override; + end; + + TORDateButton508Manager = class(TVA508ManagedComponentClass) + public + constructor Create; override; + function GetCaption(Component: TWinControl): string; override; + end; + +// TORComboEdit508Manager = class(TVA508ManagedComponentClass) +// public +// constructor Create; override; +// function Redirect(Component: TWinControl; var ManagedType: TManagedType): TWinControl; override; +// end; + +implementation + +uses VA508DelphiCompatibility, ORCtrls, ORDtTm, VA508AccessibilityRouter, + VA508AccessibilityConst, ORDtTmRng; + +function GetEditBox(ComboBox: TORComboBox): TORComboEdit; +var + i: integer; + +begin + Result := nil; + for i := 0 to ComboBox.ControlCount - 1 do + begin + if ComboBox.Controls[i] is TORComboEdit then + begin + Result := TORComboEdit(ComboBox.Controls[i]); + exit; + end; + end; +end; + +function ORComboBoxAlternateHandle(Component: TWinControl): HWnd; +var + eBox: TORComboEdit; + cBox: TORComboBox; + +begin + cBox := TORComboBox(Component); + eBox := GetEditBox(cBox); + if assigned(eBox) then + Result := eBox.Handle + else + Result := cBox.Handle; +end; + +type + TVA508RegistrationScreenReader = class(TVA508ScreenReader); +{ Registration } + +procedure RegisterORComponents; +begin + RegisterAlternateHandleComponent(TORComboBox, ORComboBoxAlternateHandle); + + RegisterManagedComponentClass(TORCheckBox508Manager.Create); + RegisterManagedComponentClass(TORComboBox508Manager.Create); + RegisterManagedComponentClass(TORListBox508Manager.Create); + RegisterManagedComponentClass(TORDayCombo508Manager.Create); + RegisterManagedComponentClass(TORMonthCombo508Manager.Create); + RegisterManagedComponentClass(TORYearEdit508Manager.Create); + RegisterManagedComponentClass(TORDateButton508Manager.Create); +// RegisterManagedComponentClass(TORComboEdit508Manager.Create); + + RegisterComplexComponentManager(TVA508TORDateComboComplexManager.Create); +// RegisterComplexComponentManager(TVA508TORComboBoxComplexManager.Create); +// RegisterComplexComponentManager(TVA508TORDateBoxComplexManager.Create); + + + with TVA508RegistrationScreenReader(GetScreenReader) do + begin +//---TORCalendar ??? +//---TORPopupMenu ??? +//---TORMenuItem ??? + + RegisterCustomClassBehavior(TORTreeView.ClassName, CLASS_BEHAVIOR_TREE_VIEW); + RegisterCustomClassBehavior(TORAlignEdit.ClassName, CLASS_BEHAVIOR_EDIT); + RegisterCustomClassBehavior(TORAlignButton.ClassName, CLASS_BEHAVIOR_BUTTON); + RegisterCustomClassBehavior(TORAlignSpeedButton.ClassName, CLASS_BEHAVIOR_BUTTON); + RegisterCustomClassBehavior(TORCheckBox.ClassName, CLASS_BEHAVIOR_CHECK_BOX); + RegisterCustomClassBehavior(TKeyClickPanel.ClassName, CLASS_BEHAVIOR_BUTTON); + RegisterCustomClassBehavior(TKeyClickRadioGroup.ClassName, CLASS_BEHAVIOR_GROUP_BOX); + RegisterCustomClassBehavior(TCaptionTreeView.ClassName, CLASS_BEHAVIOR_TREE_VIEW); + RegisterCustomClassBehavior(TCaptionMemo.ClassName, CLASS_BEHAVIOR_EDIT); + RegisterCustomClassBehavior(TCaptionEdit.ClassName, CLASS_BEHAVIOR_EDIT); + RegisterCustomClassBehavior(TCaptionRichEdit.ClassName, CLASS_BEHAVIOR_EDIT); + RegisterCustomClassBehavior(TOROffsetLabel.ClassName, CLASS_BEHAVIOR_STATIC_TEXT); + + RegisterCustomClassBehavior(TCaptionComboBox.ClassName, CLASS_BEHAVIOR_COMBO_BOX); + RegisterCustomClassBehavior(TORComboEdit.ClassName, CLASS_BEHAVIOR_EDIT_COMBO); + RegisterCustomClassBehavior(TORComboBox.ClassName, CLASS_BEHAVIOR_COMBO_BOX); + RegisterCustomClassBehavior(TORListBox.ClassName, CLASS_BEHAVIOR_LIST_BOX); + RegisterCustomClassBehavior(TCaptionCheckListBox.ClassName, CLASS_BEHAVIOR_LIST_BOX); + RegisterCustomClassBehavior(TCaptionStringGrid.ClassName, CLASS_BEHAVIOR_LIST_BOX); + + RegisterCustomClassBehavior(TORDateEdit.ClassName, CLASS_BEHAVIOR_EDIT); + RegisterCustomClassBehavior(TORDayCombo.ClassName, CLASS_BEHAVIOR_COMBO_BOX); + RegisterCustomClassBehavior(TORMonthCombo.ClassName, CLASS_BEHAVIOR_COMBO_BOX); + RegisterCustomClassBehavior(TORYearEdit.ClassName, CLASS_BEHAVIOR_EDIT); + RegisterCustomClassBehavior(TORDateBox.ClassName, CLASS_BEHAVIOR_EDIT); + RegisterCustomClassBehavior(TORDateCombo.ClassName, CLASS_BEHAVIOR_GROUP_BOX); + + RegisterCustomClassBehavior(TORListView.ClassName, CLASS_BEHAVIOR_LIST_VIEW); + RegisterCustomClassBehavior(TCaptionListView.ClassName, CLASS_BEHAVIOR_LIST_VIEW); + RegisterCustomClassBehavior(TCaptionListBox.ClassName, CLASS_BEHAVIOR_LIST_BOX); + + RegisterCustomClassBehavior(TORDateRangeDlg.ClassName, CLASS_BEHAVIOR_DIALOG); + RegisterCustomClassBehavior(TORfrmDtTm.ClassName, CLASS_BEHAVIOR_DIALOG);//called by TORDateTimeDlg + end; +end; + +{ TORCheckBox508Manager } + +constructor TORCheckBox508Manager.Create; +begin + inherited Create(TORCheckBox, [mtComponentName, mtInstructions, mtState, mtStateChange], TRUE); +end; + +function TORCheckBox508Manager.GetComponentName(Component: TWinControl): string; +begin + with TORCheckBox(Component) do + begin + if RadioStyle then + Result := 'radio button' + else + Result := VA508DelphiCompatibility.GetCheckBoxComponentName(AllowGrayed); + end; +end; + +function TORCheckBox508Manager.GetInstructions(Component: TWinControl): string; +begin + Result := VA508DelphiCompatibility.GetCheckBoxInstructionMessage(TORCheckBox(Component).Checked); +end; + +function TORCheckBox508Manager.GetState(Component: TWinControl): string; +var + cb: TORCheckBox; +begin + Application.ProcessMessages; // <<< needed to allow messages that set state to process + Result := ''; + cb := TORCheckBox(Component); + if (cb.State = cbGrayed) and (cb.GrayedStyle in [gsQuestionMark, gsBlueQuestionMark]) then + Result := 'Question Mark' + else + Result := VA508DelphiCompatibility.GetCheckBoxStateText(cb.State); +end; + +{ TORListBox508Manager } + +type + TORListBoxCheckBoxes508Manager = class(TLBMgr) + public + function GetComponentName(Component: TWinControl): string; override; + function GetState(Component: TWinControl): string; override; + function GetItemInstructions(Component: TWinControl): string; override; + end; + + TORListBoxMultiSelect508Manager = class(TLBMgr) + public + function GetComponentName(Component: TWinControl): string; override; + function GetState(Component: TWinControl): string; override; + function GetItemInstructions(Component: TWinControl): string; override; + end; + + TORListBoxStandard508Manager = class(TLBMgr) + public + function GetComponentName(Component: TWinControl): string; override; + function GetState(Component: TWinControl): string; override; + function GetItemInstructions(Component: TWinControl): string; override; + end; + +constructor TORListBox508Manager.Create; +begin + inherited Create(TORListBox, [mtComponentName, mtValue, mtState, mtStateChange, + mtItemChange, mtItemInstructions]); +end; + +destructor TORListBox508Manager.Destroy; +begin + FCurrent := nil; + if assigned(FCheckBoxes) then + FreeAndNil(FCheckBoxes); + if assigned(FMultiSelect) then + FreeAndNil(FMultiSelect); + if assigned(FStandard) then + FreeAndNil(FStandard); + inherited; +end; + +function TORListBox508Manager.GetComponentName(Component: TWinControl): string; +begin + Result := GetCurrent(Component).GetComponentName(Component); +end; + +function TORListBox508Manager.GetItem(Component: TWinControl): TObject; +var + lb : TORListBox; + max, id: integer; +begin + GetCurrent(Component); + lb := TORListBox(Component); + max := lb.items.Count + 2; + if max < 10000 then + max := 10000; + id := (lb.items.Count * max) + (lb.FocusIndex + 2); + if lb.FocusIndex < 0 then dec(id); + Result := TObject(id); +end; + +function TORListBox508Manager.GetItemInstructions( + Component: TWinControl): string; +begin + Result := GetCurrent(Component).GetItemInstructions(Component); +end; + +function TORListBox508Manager.GetState(Component: TWinControl): string; +begin + Result := GetCurrent(Component).GetState(Component); +end; + +function TORListBox508Manager.GetValue(Component: TWinControl): string; +var idx: integer; + lb: TORListBox; +begin + lb := TORListBox(Component); + idx := lb.FocusIndex; + if idx < 0 then + idx := 0; + Result := lb.DisplayText[idx]; +end; + +function TORListBox508Manager.GetCurrent(Component: TWinControl): TLBMgr; +var + lb : TORListBox; + +begin + lb := TORListBox(Component); + if lb.CheckBoxes then + begin + if not assigned(FCheckBoxes) then + FCheckBoxes := TORListBoxCheckBoxes508Manager.Create; + FCurrent := FCheckBoxes; + end + else if lb.MultiSelect then + begin + if not assigned(FMultiSelect) then + FMultiSelect := TORListBoxMultiSelect508Manager.Create; + FCurrent := FMultiSelect; + end + else + begin + if not assigned(FStandard) then + FStandard := TORListBoxStandard508Manager.Create; + FCurrent := FStandard; + end; + Result := FCurrent; +end; + +{ TORListBoxCheckBoxes508Manager } + +function TORListBoxCheckBoxes508Manager.GetComponentName( + Component: TWinControl): string; +begin + Result := 'Check List Box' +end; + +function TORListBoxCheckBoxes508Manager.GetItemInstructions( + Component: TWinControl): string; +var + lb: TORListBox; + idx: integer; +begin + Result := ''; + lb := TORListBox(Component); + idx := GetIdx(Component); + if (idx >= 0) then + Result := VA508DelphiCompatibility.GetCheckBoxInstructionMessage(lb.Checked[idx]) + else + Result := ''; +end; + +function TORListBoxCheckBoxes508Manager.GetState( + Component: TWinControl): string; +var + lb: TORListBox; + idx: integer; +begin + lb := TORListBox(Component); + idx := GetIdx(Component); + if (idx >= 0) then + begin + Result := GetCheckBoxStateText(lb.CheckedState[idx]); + if lb.FocusIndex < 0 then + Result := 'not selected ' + Result; + end + else + Result := ''; +end; + +{ TORListBoxMultiSelect508Manager } + +function TORListBoxMultiSelect508Manager.GetComponentName( + Component: TWinControl): string; +begin + Result := 'Multi Select List Box' +end; + +function TORListBoxMultiSelect508Manager.GetItemInstructions( + Component: TWinControl): string; +var + lb: TORListBox; + idx: integer; +begin + Result := ''; + lb := TORListBox(Component); + idx := GetIdx(Component); + if (idx >= 0) then + begin + if not lb.Selected[idx] then + Result := 'to select press space bar' + else + Result := 'to un select press space bar'; + end; +end; + +function TORListBoxMultiSelect508Manager.GetState( + Component: TWinControl): string; +var + lb: TORListBox; + idx: Integer; +begin + lb := TORListBox(Component); + idx := GetIdx(Component); + if (idx >= 0) then + begin + if lb.Selected[idx] then + Result := 'Selected' + else + Result := 'Not Selected'; + end + else + Result := ''; +end; + +{ TORListBoxStandard508Manager } + +function TORListBoxStandard508Manager.GetComponentName( + Component: TWinControl): string; +begin + Result := 'List Box'; +end; + +function TORListBoxStandard508Manager.GetItemInstructions( + Component: TWinControl): string; +begin + Result := ''; +end; + +function TORListBoxStandard508Manager.GetState(Component: TWinControl): string; +var + lb: TORListBox; +begin + lb := TORListBox(Component); + if (lb.FocusIndex < 0) then + Result := 'Not Selected' + else + Result := ''; +end; + +{ TLBMgr } + +function TLBMgr.GetIdx(Component: TWinControl): integer; +begin + Result := TORListBox(Component).FocusIndex; + if (Result < 0) and (TORListBox(Component).Count > 0) then + Result := 0; +end; + +{ TVA508TORDateComboComplexManager } + +constructor TVA508TORDateComboComplexManager.Create; +begin + inherited Create(TORDateCombo); +end; + +type + TORDateComboFriend = class(TORDateCombo); + +procedure TVA508TORDateComboComplexManager.Refresh(Component: TWinControl; + AccessibilityManager: TVA508AccessibilityManager); +begin + with TORDateComboFriend(Component) do + begin + ClearSubControls(Component); +// if assigned(CalBtn) then +// CalBtn.TabStop := TRUE; +// if IncludeBtn then +// AddSubControl(CalBtn, AccessibilityManager); + AddSubControl(Component, YearEdit, AccessibilityManager); +// AddSubControl(YearUD, AccessibilityManager); + if IncludeMonth then + AddSubControl(Component, MonthCombo, AccessibilityManager); + if IncludeDay then + AddSubControl(Component, DayCombo, AccessibilityManager); + end; +end; + +{ TORDayCombo508Manager } + +constructor TORDayCombo508Manager.Create; +begin + inherited Create(TORDayCombo, [mtCaption, mtValue]); +end; + +function TORDayCombo508Manager.GetCaption(Component: TWinControl): string; +begin + Result := 'Day'; +end; + +{ TORMonthCombo508Manager } + +constructor TORMonthCombo508Manager.Create; +begin + inherited Create(TORMonthCombo, [mtCaption, mtValue]); +end; + +function TORMonthCombo508Manager.GetCaption(Component: TWinControl): string; +begin + Result := 'Month'; +end; + +{ TORYearEdit508Manager } + +constructor TORYearEdit508Manager.Create; +begin + inherited Create(TORYearEdit, [mtCaption]); +end; + +function TORYearEdit508Manager.GetCaption(Component: TWinControl): string; +begin + Result := 'Year'; +end; + +{ TORDateButton508Manager } + +constructor TORDateButton508Manager.Create; +begin + inherited Create(TORDateButton, [mtCaption]); +end; + +function TORDateButton508Manager.GetCaption(Component: TWinControl): string; +begin + Result := 'Date'; +end; + +(* +{ TVA508TORDateBoxComplexManager } + +constructor TVA508TORDateBoxComplexManager.Create; +begin + inherited Create(TORDateBox); +end; + +type + TORDateBoxFriend = class(TORDateBox); + +procedure TVA508TORDateBoxComplexManager.Refresh(Component: TWinControl; + AccessibilityManager: TVA508AccessibilityManager); +begin + with TORDateBoxFriend(Component) do + begin + ClearSubControls; + if assigned(DateButton) then + begin + DateButton.TabStop := TRUE; + AddSubControl(DateButton, AccessibilityManager); + end; + end; +end; +*) + +{ TVA508ORComboManager } + +constructor TORComboBox508Manager.Create; +begin + inherited Create(TORComboBox, [mtValue], TRUE); +end; + +function TORComboBox508Manager.GetValue(Component: TWinControl): string; +begin + Result := TORComboBox(Component).Text; +end; + +{ TORComboEdit508Manager } + +//constructor TORComboEdit508Manager.Create; +//begin +// inherited Create(TORComboEdit, [mtComponentRedirect]); +//end; +// +//function TORComboEdit508Manager.Redirect(Component: TWinControl; +// var ManagedType: TManagedType): TWinControl; +//begin +// ManagedType := mtCaption; +// Result := TWinControl(Component.Owner); +//end; + +{ TVA508TORComboBoxComplexManager } + +//constructor TVA508TORComboBoxComplexManager.Create; +//begin +// inherited Create(TORComboBox); +//end; +// +//procedure TVA508TORComboBoxComplexManager.Refresh(Component: TWinControl; +// AccessibilityManager: TVA508AccessibilityManager); +//var +// eBox: TORComboEdit; +//begin +// begin +// ClearSubControls; +// eBox := GetEditBox(TORComboBox(Component)); +// if assigned(eBox) then +// AddSubControl(eBox, AccessibilityManager); +// end; +//end; + +initialization + RegisterORComponents; + +end. Index: cprs/trunk/CPRS-Lib/ORDateLib2006.dpk =================================================================== --- cprs/trunk/CPRS-Lib/ORDateLib2006.dpk (revision 829) +++ cprs/trunk/CPRS-Lib/ORDateLib2006.dpk (revision 829) @@ -0,0 +1,46 @@ +package ORDateLib2006; + +{$R *.res} +{$R 'ORDtTm.dcr'} +{$R 'ORDtTmRng.dcr'} +{$ALIGN 8} +{$ASSERTIONS ON} +{$BOOLEVAL OFF} +{$DEBUGINFO OFF} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS ON} +{$RANGECHECKS ON} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'CPRS Date/Time Dialogs'} +{$DESIGNONLY} +{$IMPLICITBUILD ON} + +requires + vclsmp, + vcl, + tee, + ORCtrlLib2006, + XWB_R10; + +contains + ORDtTmCal in 'ORDtTmCal.pas', + ORDtTm in 'ORDtTm.pas', + ORDtTmRng in 'ORDtTmRng.pas', + ORNet in 'ORNet.pas', + ORFn in 'ORFn.pas', + OR2006Compatibility in 'OR2006Compatibility.pas' {frm2006Compatibility}; + +end. Index: cprs/trunk/CPRS-Lib/ORDateLib2006.drc =================================================================== --- cprs/trunk/CPRS-Lib/ORDateLib2006.drc (revision 829) +++ cprs/trunk/CPRS-Lib/ORDateLib2006.drc (revision 829) @@ -0,0 +1,14 @@ +/* VER180 + Generated by the Borland Delphi Pascal Compiler + because -GD or --drc was supplied to the compiler. + + This file contains compiler-generated resources that + were bound to the executable. + If this file is empty, then no compiler-generated + resources were bound to the produced executable. +*/ + +STRINGTABLE +BEGIN +END + Index: cprs/trunk/CPRS-Lib/ORDtTm.dfm =================================================================== --- cprs/trunk/CPRS-Lib/ORDtTm.dfm (revision 456) +++ cprs/trunk/CPRS-Lib/ORDtTm.dfm (revision 829) @@ -1,5 +1,5 @@ object ORfrmDtTm: TORfrmDtTm - Left = 550 - Top = 474 + Left = 586 + Top = 483 BorderIcons = [] BorderStyle = bsDialog Index: cprs/trunk/CPRS-Lib/ORDtTm.pas =================================================================== --- cprs/trunk/CPRS-Lib/ORDtTm.pas (revision 456) +++ cprs/trunk/CPRS-Lib/ORDtTm.pas (revision 829) @@ -7,8 +7,9 @@ uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, Buttons, - Grids, Calendar, ExtCtrls, ORFn, ORNet, ORDtTmCal, Mask, ComCtrls, ORCtrls; + Grids, Calendar, ExtCtrls, ORFn, ORNet, ORDtTmCal, Mask, ComCtrls, OR2006Compatibility, + ORCtrls, VAClasses; type - TORfrmDtTm = class(TForm) + TORfrmDtTm = class(Tfrm2006Compatibility) bvlFrame: TBevel; lblDate: TPanel; @@ -51,4 +52,6 @@ FNowPressed: Boolean; TimeIsRequired: Boolean; + protected + procedure Loaded; override; end; @@ -75,4 +78,7 @@ end; + // 508 class + TORDateButton = class (TBitBtn); + { TORDateBox } @@ -82,14 +88,15 @@ end; - TORDateBox = class(TORDateEdit) + TORDateBox = class(TORDateEdit, IVADynamicProperty, IORBlackColorModeCompatible) private FFMDateTime: TFMDateTime; FDateOnly: Boolean; FRequireTime: Boolean; - FButton: TBitBtn; + FButton: TORDateButton; FFormat: string; FTimeIsNow: Boolean; FTemplateField: boolean; FCaption: TStaticText; + FBlackColorMode: boolean; procedure ButtonClick(Sender: TObject); function GetFMDateTime: TFMDateTime; @@ -104,12 +111,15 @@ procedure SetCaption(const Value: string); function GetCaption(): string; - protected procedure Change; override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; + property DateButton: TORDateButton read FButton; public constructor Create(AOwner: TComponent); override; function IsValid: Boolean; procedure Validate(var ErrMsg: string); + procedure SetBlackColorMode(Value: boolean); + function SupportsDynamicProperty(PropertyID: integer): boolean; + function GetDynamicProperty(PropertyID: integer): string; property Format: string read FFormat write FFormat; property RelativeTime: string read GetRelativeTime; @@ -122,12 +132,25 @@ end; - TORDateCombo = class(TCustomPanel) + // 508 classes + TORDayCombo = class (TORComboBox); + TORMonthCombo = class (TORComboBox); + TORYearEdit = class(TMaskEdit) + private + FTemplateField: boolean; + procedure SetTemplateField(const Value: boolean); + protected + property TemplateField: boolean read FTemplateField write SetTemplateField; + end; + + TORYearEditClass = Class of TORYearEdit; + + TORDateCombo = class(TCustomPanel, IORBlackColorModeCompatible) private FYearChanging: boolean; - FMonthCombo: TORComboBox; - FDayCombo: TORComboBox; - FYearEdit: TMaskEdit; + FMonthCombo: TORMonthCombo; + FDayCombo: TORDayCombo; + FYearEdit: TORYearEdit; FYearUD: TUpDown; - FCalBtn: TSpeedButton; + FCalBtn: TORDateButton; FIncludeMonth: boolean; FIncludeDay: boolean; @@ -141,4 +164,6 @@ FRebuilding: boolean; FTemplateField: boolean; + FBlackColorMode: boolean; + FORYearEditClass: TORYearEditClass; procedure SetIncludeBtn(const Value: boolean); procedure SetIncludeDay(Value: boolean); @@ -153,5 +178,5 @@ procedure SetTemplateField(const Value: boolean); protected - procedure Rebuild; + procedure Rebuild; virtual; function InitDays(GetSize: boolean): integer; function InitMonths(GetSize: boolean): integer; @@ -169,8 +194,15 @@ procedure Paint; override; procedure Resized(Sender: TObject); + property MonthCombo: TORMonthCombo read FMonthCombo; + property DayCombo: TORDayCombo read FDayCombo; + property YearEdit: TORYearEdit read FYearEdit; + property YearUD: TUpDown read FYearUD; + property CalBtn: TORDateButton read FCalBtn; + property ORYearEditClass: TORYearEditClass read FORYearEditClass write FORYearEditClass; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function DateText: string; + procedure SetBlackColorMode(Value: boolean); property TemplateField: boolean read FTemplateField write SetTemplateField; property FMDate: TFMDateTime read GetFMDate write SetFMDate; @@ -280,4 +312,15 @@ end; +procedure LoadEllipsis(bitmap: TBitMap; BlackColorMode: boolean); +var + ResName: string; +begin + if BlackColorMode then + ResName := 'BLACK_BMP_ELLIPSIS' + else + ResName := 'BMP_ELLIPSIS'; + bitmap.LoadFromResourceName(hInstance, ResName); +end; + { TfrmORDtTm -------------------------------------------------------------------------------- } @@ -351,4 +394,5 @@ procedure TORfrmDtTm.lstHourClick(Sender: TObject); begin + if lstHour.ItemIndex = 0 then lstMinute.Items[0] := ':01 --' else lstMinute.Items[0] := ':00 --'; //<------ NEW CODE if lstMinute.ItemIndex < 0 then lstMinute.ItemIndex := 0; lstMinuteClick(Self); @@ -374,4 +418,5 @@ AMinute := lstMinute.ItemIndex * 5; + if (AnHour = 0) and (AMinute = 0) then AMinute := 1; //<-------------- NEW CODE FFromSelf := True; // if ampm time - @@ -410,5 +455,6 @@ begin x := Trim(txtTime.Text); - if (x='00:00') or (x='0:00') or (x='00:00:00') or (x='0:00:00') then x := '00:00:01'; + //if (x='00:00') or (x='0:00') or (x='00:00:00') or (x='0:00:00') then x := '00:00:01'; + if (x='00:00') or (x='0:00') or (x='00:00:00') or (x='0:00:00') then x := '00:01'; //<------- CHANGED CODE StrToTime(x); txtTime.Text := x; @@ -420,4 +466,10 @@ begin ModalResult := mrCancel; +end; + +procedure TORfrmDtTm.Loaded; +begin + inherited Loaded; + UpdateColorsFor508Compliance(Self); end; @@ -515,5 +567,5 @@ begin inherited Create(AOwner); - FButton := TBitBtn.Create(Self); + FButton := TORDateButton.Create(Self); FButton.Parent := Self; FButton.Width := 18; @@ -521,5 +573,6 @@ FButton.OnClick := ButtonClick; FButton.TabStop := False; - FButton.Glyph.LoadFromResourceName(hInstance, 'BMP_ELLIPSIS'); + FBlackColorMode := False; + LoadEllipsis(FButton.Glyph, FALSE); FButton.Visible := True; FFormat := FMT_DATETIME; @@ -567,4 +620,9 @@ end; +function TORDateBox.SupportsDynamicProperty(PropertyID: integer): boolean; +begin + Result := (PropertyID = DynaPropAccesibilityCaption); +end; + procedure TORDateBox.ButtonClick(Sender: TObject); var @@ -696,4 +754,13 @@ if Length(x) = 0 then Result := True else Result := False; if Length(Text) = 0 then Result := False; +end; + +procedure TORDateBox.SetBlackColorMode(Value: boolean); +begin + if FBlackColorMode <> Value then + begin + FBlackColorMode := Value; + LoadEllipsis(FButton.Glyph, FBlackColorMode); + end; end; @@ -717,4 +784,12 @@ end; +function TORDateBox.GetDynamicProperty(PropertyID: integer): string; +begin + if PropertyID = DynaPropAccesibilityCaption then + Result := GetCaption + else + Result := ''; +end; + function IsLeapYear(AYear: Integer): Boolean; begin @@ -745,16 +820,7 @@ LastYear = 2200; -type - TORDateComboEdit = class(TMaskEdit) - private - FTemplateField: boolean; - procedure SetTemplateField(const Value: boolean); - protected - property TemplateField: boolean read FTemplateField write SetTemplateField; - end; - { TORDateComboEdit } -procedure TORDateComboEdit.SetTemplateField(const Value: boolean); +procedure TORYearEdit.SetTemplateField(const Value: boolean); begin if(FTemplateField <> Value) then @@ -779,4 +845,5 @@ FIncludeBtn := TRUE; OnResize := Resized; + FORYearEditClass := TORYearEdit; end; @@ -868,5 +935,5 @@ if(not assigned(FMonthCombo)) then begin - FMonthCombo := TORComboBox.Create(Self); + FMonthCombo := TORMonthCombo.Create(Self); FMonthCombo.Parent := Self; FMonthCombo.Top := 0; @@ -874,4 +941,5 @@ FMonthCombo.Style := orcsDropDown; FMonthCombo.DropDownCount := 13; + FMonthCombo.ListItemsOnly := True; FMonthCombo.OnChange := MonthChanged; end; @@ -888,8 +956,9 @@ if(not assigned(FDayCombo)) then begin - FDayCombo := TORComboBox.Create(Self); + FDayCombo := TORDayCombo.Create(Self); FDayCombo.Parent := Self; FDayCombo.Top := 0; FDayCombo.Style := orcsDropDown; + FDayCombo.ListItemsOnly := True; FDayCombo.OnChange := DayChanged; FDayCombo.DropDownCount := 11; @@ -914,5 +983,5 @@ if(not assigned(FYearEdit)) then begin - FYearEdit := TORDateComboEdit.Create(Self); + FYearEdit := FORYearEditClass.Create(Self); FYearEdit.Parent := Self; FYearEdit.Top := 0; @@ -922,5 +991,5 @@ end; FYearEdit.Font := Font; - TORDateComboEdit(FYearEdit).TemplateField := FTemplateField; + FYearEdit.TemplateField := FTemplateField; Wide := GetYearSize; FYearEdit.Width := Wide; @@ -947,8 +1016,9 @@ if(not assigned(FCalBtn)) then begin - FCalBtn := TSpeedButton.Create(Self); + FCalBtn := TORDateButton.Create(Self); + FCalBtn.TabStop := FALSE; FCalBtn.Parent := Self; FCalBtn.Top := 0; - FCalBtn.Glyph.LoadFromResourceName(hInstance, 'BMP_ELLIPSIS'); + LoadEllipsis(FCalBtn.Glyph, FBlackColorMode); FCalBtn.OnClick := BtnClicked; end; @@ -973,4 +1043,14 @@ FRebuilding := FALSE; end; + end; +end; + +procedure TORDateCombo.SetBlackColorMode(Value: boolean); +begin + if FBlackColorMode <> Value then + begin + FBlackColorMode := Value; + if assigned(FCalBtn) then + LoadEllipsis(FCalBtn.Glyph, FBlackColorMode); end; end; Index: cprs/trunk/CPRS-Lib/ORDtTmRng.dfm =================================================================== --- cprs/trunk/CPRS-Lib/ORDtTmRng.dfm (revision 456) +++ cprs/trunk/CPRS-Lib/ORDtTmRng.dfm (revision 829) @@ -18,5 +18,5 @@ Left = 8 Top = 44 - Width = 53 + Width = 52 Height = 13 Caption = 'Begin Date' @@ -25,5 +25,5 @@ Left = 145 Top = 44 - Width = 45 + Width = 44 Height = 13 Caption = 'End Date' Index: cprs/trunk/CPRS-Lib/ORDtTmRng.pas =================================================================== --- cprs/trunk/CPRS-Lib/ORDtTmRng.pas (revision 456) +++ cprs/trunk/CPRS-Lib/ORDtTmRng.pas (revision 829) @@ -5,8 +5,8 @@ uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, ORFn, ORDtTm; + StdCtrls, ORFn, OR2006Compatibility, ORDtTm; type - TORfrmDateRange = class(TForm) + TORfrmDateRange = class(Tfrm2006Compatibility) lblStart: TLabel; lblStop: TLabel; @@ -21,4 +21,6 @@ FCalStart: TORDateBox; FCalStop: TORDateBox; + protected + procedure Loaded; override; end; @@ -217,4 +219,5 @@ FCalStop.TabOrder := 1; ResizeAnchoredFormToFont(self); + UpdateColorsFor508Compliance(self); end; @@ -225,3 +228,9 @@ end; +procedure TORfrmDateRange.Loaded; +begin + inherited Loaded; + UpdateColorsFor508Compliance(Self); +end; + end. Index: cprs/trunk/CPRS-Lib/ORFn.pas =================================================================== --- cprs/trunk/CPRS-Lib/ORFn.pas (revision 456) +++ cprs/trunk/CPRS-Lib/ORFn.pas (revision 829) @@ -6,5 +6,5 @@ uses SysUtils, Windows, Messages, Classes, Controls, StdCtrls, ExtCtrls, ComCtrls, Forms, - Graphics, Menus, RichEdit; + Graphics, Menus, RichEdit, Buttons; const @@ -13,5 +13,7 @@ BOOLCHAR: array[Boolean] of Char = ('0', '1'); UM_STATUSTEXT = (WM_USER + 302); // used to send update status msg to main form - COLOR_CREAM = $F0FBFF; + +var + ScrollBarHeight: integer = 0; type @@ -66,4 +68,7 @@ function DelimCount(const Str, Delim: string): integer; procedure QuickCopy(AFrom, ATo: TObject); +procedure QuickAdd(AFrom, ATo: TObject); +procedure FastAssign(source, destination: TStrings); +procedure FastAddStrings(source, destination: TStrings); function ValidFileName(const InitialFileName: string): string; @@ -84,4 +89,5 @@ procedure ResizeFormToFont(AForm: TForm); procedure ResizeAnchoredFormToFont( AForm: TForm); +procedure AdjustForWindowsXPStyleTitleBar(AForm: TForm); function ResizeWidth( OldFont: TFont; NewFont: TFont; OldWidth: integer): integer; function ResizeHeight( OldFont: TFont; NewFont: TFont; OldHeight: integer): integer; @@ -96,5 +102,10 @@ function PopupComponent(Sender: TObject; PopupMenu: TPopupMenu): TComponent; procedure ReformatMemoParagraph(AMemo: TCustomMemo); -function ReadOnlyColor: TColor; + +function BlackColorScheme: Boolean; +function NormalColorScheme: Boolean; +function Get508CompliantColor(Color: TColor): TColor; +procedure UpdateColorsFor508Compliance(control: TControl; InputEditControl: boolean = FALSE); +procedure UpdateReadOnlyColorScheme(Control: TControl; ReadOnly: boolean); { ListBox Grid functions } @@ -116,9 +127,10 @@ function TabIsPressed : Boolean; function ShiftTabIsPressed : Boolean; +function EnterIsPressed : Boolean; implementation // --------------------------------------------------------------------------- uses - ORCtrls, Grids, Chart, CheckLst; + ORCtrls, Grids, Chart, CheckLst, VAUtils; const @@ -606,29 +618,11 @@ function Piece(const S: string; Delim: char; PieceNum: Integer): string; { returns the Nth piece (PieceNum) of a string delimited by Delim } -var - i: Integer; - Strt, Next: PChar; -begin - i := 1; - Strt := PChar(S); - Next := StrScan(Strt, Delim); - while (i < PieceNum) and (Next <> nil) do - begin - Inc(i); - Strt := Next + 1; - Next := StrScan(Strt, Delim); - end; - if Next = nil then Next := StrEnd(Strt); - if i < PieceNum then Result := '' else SetString(Result, Strt, Next - Strt); +begin + Result := VAUtils.Piece(S, Delim, PieceNum); end; function Pieces(const S: string; Delim: char; FirstNum, LastNum: Integer): string; -{ returns several contiguous pieces } -var - PieceNum: Integer; -begin - Result := ''; - for PieceNum := FirstNum to LastNum do Result := Result + Piece(S, Delim, PieceNum) + Delim; - if Length(Result) > 0 then Delete(Result, Length(Result), 1); +begin + Result := VAUtils.Pieces(S, Delim, FirstNum, LastNum); end; @@ -779,4 +773,10 @@ if obj is TListBox then str[idx] := TListBox(obj).Items + else + if obj is TORComboBox then + str[idx] := TORComboBox(obj).Items + else + if obj is TComboBox then + str[idx] := TComboBox(obj).Items else if obj is TRichEdit then @@ -815,4 +815,125 @@ if fix[0] then TRichEdit(AFrom).PlainText := FALSE; if fix[1] then TRichEdit(ATo).PlainText := FALSE; + if ATo is TRichEdit then + TRichEdit(ATo).SelStart := Length(TRichEdit(ATo).Lines.Text); //CQ: 16461 +end; + +type + QuickAddError = class(Exception); + +procedure QuickAdd(AFrom, ATo: TObject); +var + ms: TMemoryStream; + idx: integer; + str: array[0..1] of TStrings; + fix: array[0..1] of boolean; + + procedure GetStrings(obj: TObject); + begin + if (CompareText(obj.ClassName, 'TRichEditStrings') = 0) then + raise QuickCopyError.Create('You must pass the TRichEdit object into QuickAdd, NOT it''s Lines property.'); + if obj is TStrings then + str[idx] := TStrings(obj) + else + if obj is TMemo then + str[idx] := TMemo(obj).Lines + else + if obj is TORListBox then + str[idx] := TORListBox(obj).Items + else + if obj is TListBox then + str[idx] := TListBox(obj).Items + else + if obj is TORComboBox then + str[idx] := TORComboBox(obj).Items + else + if obj is TComboBox then + str[idx] := TComboBox(obj).Items + else + if obj is TRichEdit then + begin + with TRichEdit(obj) do + begin + str[idx] := Lines; + if not PlainText then + begin + fix[idx] := TRUE; + PlainText := TRUE; + end; + end; + end + else + raise QuickAddError.Create('Unsupported object type (' + obj.ClassName + + ') passed into QuickAdd.'); + inc(idx); + end; + + +begin + fix[0] := FALSE; + fix[1] := FALSE; + idx := 0; + GetStrings(AFrom); + GetStrings(ATo); + ms := TMemoryStream.Create; + try + str[1].SaveToStream(ms); + ms.Seek(0, soFromEnd); + str[0].SaveToStream(ms); + ms.Seek(0, soFromBeginning); + str[1].Clear; + str[1].LoadFromStream(ms); + finally + ms.Free; + end; + if fix[0] then TRichEdit(AFrom).PlainText := FALSE; + if fix[1] then TRichEdit(ATo).PlainText := FALSE; +end; + +procedure FastAssign(source, destination: TStrings); +// do not use this with RichEdit Lines unless source is RichEdit with PlainText +var + ms: TMemoryStream; +begin + destination.Clear; + if (source is TStringList) and (destination is TStringList) then + destination.Assign(source) + else + if (CompareText(source.ClassName, 'TRichEditStrings') = 0) then + destination.Assign(source) + else + begin + ms := TMemoryStream.Create; + try + source.SaveToStream(ms); + ms.Seek(0, soFromBeginning); + destination.LoadFromStream(ms); + finally + ms.Free; + end; + end; +end; + +procedure FastAddStrings(source, destination: TStrings); +// do not use this with RichEdit Lines unless source and destination are RichEdit with PlainText +var + ms: TMemoryStream; +begin + if (source is TStringList) and (destination is TStringList) then + destination.AddStrings(source) + else + begin + ms := TMemoryStream.Create; + try + destination.SaveToStream(ms); + ms.Seek(0, soFromEnd); + source.SaveToStream(ms); + ms.Seek(0, soFromBeginning); + destination.Clear; + destination.LoadFromStream(ms); + finally + ms.Free; + end; + end; end; @@ -861,5 +982,5 @@ end; {for i} AList.Clear; - AList.Assign(NewList); + FastAssign(NewList, AList); finally NewList.Free; @@ -1248,20 +1369,109 @@ end; +var + AlignList, AnchorList: TStringList; + +function AnchorsToStr(Control: TControl): string; +var + j: TAnchorKind; + +begin + Result := ''; + for j := low(TAnchorKind) to high(TAnchorKind) do + if j in Control.Anchors then + Result := result + '1' + else + Result := result + '0' +end; + +function StrToAnchors(i: integer): TAnchors; +var + j: TAnchorKind; + value: string; + idx : integer; +begin + Result := []; + value := AnchorList[i]; + idx := 1; + for j := low(TAnchorKind) to high(TAnchorKind) do + begin + if copy(value,idx,1) = '1' then + include(Result, j); + inc(idx); + end; +end; + +procedure SuspendAlign(AForm: TForm); +var + i: integer; + control: TControl; +begin + AForm.DisableAlign; + AlignList.Clear; + AnchorList.Clear; + for i := 0 to AForm.ControlCount-1 do + begin + control := AForm.Controls[i]; + AlignList.Add(IntToStr(ord(control.align))); + control.Align := alNone; + AnchorList.Add(AnchorsToStr(control)); + control.Anchors := []; + end; +end; + +procedure RestoreAlign(AForm: TForm); +var + i: integer; + control: TControl; +begin + try + for i := 0 to AForm.ControlCount-1 do + begin + control := AForm.Controls[i]; + control.Align := TAlign(StrToIntDef(AlignList[i],0)); + control.Anchors := StrToAnchors(i); + end; + AlignList.Clear; + AnchorList.Clear; + finally + AForm.EnableAlign; + end; +end; + procedure ResizeFormToFont(AForm: TForm); var Rect: TRect; -begin + OldResize: TNotifyEvent; +begin +// CQ# 11481 apply size changes to form all at once, instead of piece by piece. Otherwise, +// multiple calls to fAutoSz.FormResize, even if the form has not resized, can distort +// the controls beyond the size of the form. with AForm do begin - ClientWidth := ResizeWidth( Font, MainFont, ClientWidth); - ClientHeight := ResizeHeight( Font, MainFont, ClientHeight); - HorzScrollBar.Range := ResizeWidth( Font, MainFont, HorzScrollBar.Range); - VertScrollBar.Range := ResizeHeight( Font, MainFont, VertScrollBar.Range); - Rect := BoundsRect; - ForceInsideWorkArea(Rect); - BoundsRect := Rect; - ResizeFontsInDescendants( Font, MainFont, AForm); - //Important: We are using the font to calculate everything, so don't - //change font until now. - Font.Size := MainFont.Size; + OldResize := AForm.OnResize; + AForm.OnResize := nil; + try + SuspendAlign(AForm); + try + HorzScrollBar.Range := ResizeWidth( Font, MainFont, HorzScrollBar.Range); + VertScrollBar.Range := ResizeHeight( Font, MainFont, VertScrollBar.Range); + ClientWidth := ResizeWidth( Font, MainFont, ClientWidth); + ClientHeight := ResizeHeight( Font, MainFont, ClientHeight); + Rect := BoundsRect; + ForceInsideWorkArea(Rect); + BoundsRect := Rect; + finally + RestoreAlign(AForm); + end; + ResizeFontsInDescendants( Font, MainFont, AForm); + //Important: We are using the font to calculate everything, so don't + //change font until now. + Font.Size := MainFont.Size; + finally + if(Assigned(OldResize)) then + begin + AForm.OnResize := OldResize; + OldResize(AForm); + end; + end; end; end; @@ -1270,18 +1480,66 @@ var Rect: TRect; + OldResize: TNotifyEvent; + begin with AForm do begin - ClientWidth := ResizeWidth( Font, MainFont, ClientWidth); - ClientHeight := ResizeHeight( Font, MainFont, ClientHeight); - HorzScrollBar.Range := ResizeWidth( Font, MainFont, HorzScrollBar.Range); - VertScrollBar.Range := ResizeHeight( Font, MainFont, VertScrollBar.Range); - Rect := BoundsRect; - ForceInsideWorkArea(Rect); - BoundsRect := Rect; - ResizeDescendants( Font, MainFont, AForm); - ResizeFontsInDescendants( Font, MainFont, AForm); - //Important: We are using the font to calculate everything, so don't - //change font until now. - Font.Size := MainFont.Size; + // CQ# 11481 - see ResizeFormToFont + OldResize := AForm.OnResize; + AForm.OnResize := nil; + try + HorzScrollBar.Range := ResizeWidth( Font, MainFont, HorzScrollBar.Range); + VertScrollBar.Range := ResizeHeight( Font, MainFont, VertScrollBar.Range); + ClientWidth := ResizeWidth( Font, MainFont, ClientWidth); + ClientHeight := ResizeHeight( Font, MainFont, ClientHeight); + Rect := BoundsRect; + ForceInsideWorkArea(Rect); + BoundsRect := Rect; + ResizeDescendants( Font, MainFont, AForm); + ResizeFontsInDescendants( Font, MainFont, AForm); + //Important: We are using the font to calculate everything, so don't + //change font until now. + Font.Size := MainFont.Size; + finally + if(Assigned(OldResize)) then + begin + AForm.OnResize := OldResize; + OldResize(AForm); + end; + end; + end; +end; + +// CQ 11485 - Adjusts all forms - adds additional height to the form to +// adjust for Windows XP style title bars, and for large fonts in title bar +procedure AdjustForWindowsXPStyleTitleBar(AForm: TForm); +const + DEFAULT_CAPTION_HEIGHT = 19; + DEFAULT_MENU_HEIGHT = 19; + +var + dxsb, dysb, dy, menuDY: integer; + +begin +// Call GetSystemMetrics each time because values can change between calls + dy := GetSystemMetrics(SM_CYCAPTION) - DEFAULT_CAPTION_HEIGHT; + if (AForm.Menu <> nil) then + begin + menuDY := GetSystemMetrics(SM_CYMENU) - DEFAULT_MENU_HEIGHT; + inc(dy, menuDY); + end; + if dy <> 0 then + begin + SuspendAlign(AForm); + try + // Assitional adjustment to allow scroll bars to dissappear + dxsb := GetSystemMetrics(SM_CXVSCROLL); + dysb := GetSystemMetrics(SM_CYHSCROLL); + AForm.Height := AForm.Height + dy + dysb; + AForm.Width := AForm.Width + dxsb; + AForm.Height := AForm.Height - dysb; + AForm.Width := AForm.Width - dxsb; + finally + RestoreAlign(AForm); + end; end; end; @@ -1329,9 +1587,15 @@ begin DC := GetDC(0); - SaveFont := SelectObject(DC, AFontHandle); - GetTextExtentPoint32(DC, PChar(x), Length(x), TextSize); - Result := TextSize.cx; - SelectObject(DC, SaveFont); - ReleaseDC(0, DC); + try + SaveFont := SelectObject(DC, AFontHandle); + try + GetTextExtentPoint32(DC, PChar(x), Length(x), TextSize); + Result := TextSize.cx; + finally + SelectObject(DC, SaveFont); + end; + finally + ReleaseDC(0, DC); + end; end; @@ -1344,9 +1608,17 @@ begin DC := GetDC(0); - SaveFont := SelectObject(DC, AFontHandle); - GetTextExtentPoint32(DC, PChar(x), Length(x), TextSize); - Result := TextSize.cy; - SelectObject(DC, SaveFont); - ReleaseDC(0, DC); + try + SaveFont := SelectObject(DC, AFontHandle); + try + GetTextExtentPoint32(DC, PChar(x), Length(x), TextSize); + Result := TextSize.cy; + finally + SelectObject(DC, SaveFont); + end; + finally + ReleaseDC(0, DC); + end; + if Result > 255 then // CQ 11493 + Result := 255; // This is maximum allowed by a Windows end; @@ -1393,4 +1665,6 @@ end; end; + if Result > 255 then // CQ 11492 + Result := 255; // This is maximum allowed by a Windows end; @@ -1471,18 +1745,213 @@ var - uReadOnlyColor: TColor; - uHaveReadOnlyColor: boolean = FALSE; - -function ReadOnlyColor: TColor; -begin - if not uHaveReadOnlyColor then - begin - uHaveReadOnlyColor := TRUE; - if ColorToRGB(clWindow) = ColorToRGB(clWhite) then - uReadOnlyColor := $00F0FBFF + uNormalColorScheme: boolean = false; + uBlackColorScheme: boolean = false; + uWhiteColorScheme: boolean = false; + uMaroonColorWhenBlack: TColor = clMaroon; + uCheckColorScheme: boolean = true; + PURE_BLACK: longint = 0; + +const + uBorderlessWindowColorWhenBlack: TColor = clNavy; + + +procedure CheckColorScheme; +begin + if uCheckColorScheme then + begin + uNormalColorScheme := + ((ColorToRGB(clWindow) = ColorToRGB(clWhite)) and + (ColorToRGB(clWindowText) = ColorToRGB(clBlack)) and + (ColorToRGB(clInfoText) = ColorToRGB(clBlack)) and + (ColorToRGB(clInfoBk) <> ColorToRGB(clWhite))); + + uBlackColorScheme := ((ColorToRGB(clBtnFace) = ColorToRGB(clBlack)) and + (ColorToRGB(clWindow) = ColorToRGB(clBlack))); + uWhiteColorScheme := ((ColorToRGB(clBtnFace) = ColorToRGB(clWhite)) and + (ColorToRGB(clWindow) = ColorToRGB(clWhite))); + + if uBlackColorScheme then + begin + if(ColorToRGB(clGrayText) = ColorToRGB(clWindowText)) then + uMaroonColorWhenBlack := clHighlightText + else + uMaroonColorWhenBlack := clGrayText; + end; + + uCheckColorScheme := FALSE; + end; +end; + +function BlackColorScheme: Boolean; +begin + if uCheckColorScheme then CheckColorScheme; + Result := uBlackColorScheme; +end; + +function NormalColorScheme: Boolean; +begin + if uCheckColorScheme then CheckColorScheme; + Result := uNormalColorScheme; +end; + +function Get508CompliantColor(Color: TColor): TColor; +begin + Result := Color; + if NormalColorScheme then exit; + + case Color of + clCream: Result := clInfoBk; + clBlack: Result := clWindowText; + clWhite: Result := clWindow; + end; + + if uBlackColorScheme then + begin + case Color of + clBlue: Result := clAqua; + clMaroon: Result := uMaroonColorWhenBlack; + // clRed: Result := clFuchsia; + end; + end; + + if uWhiteColorScheme then + begin + case Color of + clGrayText: Result := clGray; + end; + end; +end; + +type + TExposedControl = class(TControl) + public + property Color; + property Font; + end; + + TExposedCustomEdit = class(TCustomEdit) + public + property BorderStyle; + property ReadOnly; + end; + +procedure UpdateColorsFor508Compliance(control: TControl; InputEditControl: boolean = FALSE); +var + BitMapLevelCheck: integer; + Level: integer; + + + procedure BlackColorSchemeUpdate(control: TControl); + var + bitmap: TBitMap; + edit: TExposedCustomEdit; + x,y: integer; + cbmCtrl: IORBlackColorModeCompatible; + + begin + if uBlackColorScheme then + begin + if Level < BitMapLevelCheck then + begin + if control.GetInterface(IORBlackColorModeCompatible, cbmCtrl) then + begin + cbmCtrl.SetBlackColorMode(TRUE); + BitMapLevelCheck := Level; + cbmCtrl := nil; + end + else + begin + if (control is TBitBtn) then + begin + bitmap := TBitBtn(control).Glyph; + for x := 0 to bitmap.Width-1 do + begin + for y := 0 to bitmap.Height-1 do + begin + if ColorToRGB(bitmap.Canvas.Pixels[x,y]) = PURE_BLACK then + bitmap.Canvas.Pixels[x,y] := clWindowText; + end; + end; + end; + end; + end; + + if (control is TCustomEdit) and InputEditControl then + begin + edit := TExposedCustomEdit(control); + if (edit.BorderStyle = bsNone) then + edit.Color := uBorderlessWindowColorWhenBlack; + end; + + end; + end; + + procedure ComponentUpdateColorsFor508Compliance(control: TControl); + var + OldComponentColor, OldFontColor, NewComponentColor, NewFontColor: TColor; + begin + OldComponentColor := TExposedControl(control).Color; + OldFontColor := TExposedControl(control).Font.Color; + NewComponentColor := Get508CompliantColor(OldComponentColor); + if NewComponentColor = clInfoBk then + begin + if (OldFontColor = clInfoBk) or (OldFontColor = clCream) then + NewFontColor := clInfoBk // used for hiding text + else + NewFontColor := clInfoText; + end else - uReadOnlyColor := clWindow; - end; - Result := uReadOnlyColor; + NewFontColor := Get508CompliantColor(OldFontColor); + if NewComponentColor <> OldComponentColor then + TExposedControl(control).Color := NewComponentColor; + if NewFontColor <> OldFontColor then + TExposedControl(control).Font.Color := NewFontColor; + BlackColorSchemeUpdate(control); + end; + + procedure ScanAllComponents(control: TControl); + var + i: integer; + + begin + ComponentUpdateColorsFor508Compliance(Control); + if control is TWinControl then + begin + inc(Level); + try + for i := 0 to TWinControl(Control).ControlCount-1 do + begin + ScanAllComponents(TWinControl(Control).Controls[i]); + end; + finally + dec(Level); + if BitMapLevelCheck = Level then + BitMapLevelCheck := MaxInt; + end; + end; + end; + +begin + if NormalColorScheme then exit; + BitMapLevelCheck := MaxInt; + Level := 0; + ScanAllComponents(control); +end; + +procedure UpdateReadOnlyColorScheme(Control: TControl; ReadOnly: boolean); +begin + with TExposedControl(Control) do + begin + if ReadOnly then + begin + Color := Get508CompliantColor(clCream); + Font.Color := clInfoText; + end + else + begin + Color := clWindow; + Font.Color := clWindowText; + end; + end; end; @@ -1521,5 +1990,5 @@ end; Canvas.FillRect(ARect); - Canvas.Pen.Color := clSilver; + Canvas.Pen.Color := Get508CompliantColor(clSilver); Canvas.MoveTo(ARect.Left, ARect.Bottom - 1); Canvas.LineTo(ARect.Right, ARect.Bottom - 1); @@ -1714,4 +2183,5 @@ begin Result := Boolean(Hi(GetKeyState(VK_TAB))) and not Boolean(Hi(GetKeyState(VK_SHIFT))); + Result := Result and not Boolean(Hi(GetKeyState(VK_CONTROL))); end; @@ -1719,6 +2189,11 @@ begin Result := Boolean(Hi(GetKeyState(VK_TAB))) and Boolean(Hi(GetKeyState(VK_SHIFT))); -end; - + Result := Result and not Boolean(Hi(GetKeyState(VK_CONTROL))); +end; + +function EnterIsPressed : Boolean; +begin + Result := Boolean(Hi(GetKeyState(VK_RETURN))); +end; initialization @@ -1726,8 +2201,14 @@ FBaseFont.Name := BaseFontName; FBaseFont.Size := BaseFontSize; + ScrollBarHeight := GetSystemMetrics(SM_CYHSCROLL); + AlignList := TStringList.Create; + AnchorList := TStringList.Create; + PURE_BLACK := ColorToRGB(clBlack); finalization FBaseFont.Free; KillObj(@IdleCaller); + FreeAndNil(AlignList); + FreeAndNil(AnchorList); end. Index: cprs/trunk/CPRS-Lib/ORNet.pas =================================================================== --- cprs/trunk/CPRS-Lib/ORNet.pas (revision 456) +++ cprs/trunk/CPRS-Lib/ORNet.pas (revision 829) @@ -43,4 +43,6 @@ {$ENDIF} RPCLastCall: string; + + AppStartedCursorForm: TForm = nil; implementation @@ -263,5 +265,5 @@ AStringList.Add(' '); AStringList.Add('Results -----------------------------------------------------------------'); - AStringList.AddStrings(RPCBrokerV.Results); + FastAddStrings(RPCBrokerV.Results, AStringList); uCallList.Add(AStringList); if uShowRPCs then StatusText(''); @@ -347,4 +349,17 @@ end; +function GetRPCCursor: TCursor; +var + pt: TPoint; +begin + Result := crHourGlass; + if assigned(AppStartedCursorForm) and (AppStartedCursorForm.Visible) then + begin + pt := Mouse.CursorPos; + if PtInRect(AppStartedCursorForm.BoundsRect, pt) then + Result := crAppStart; + end; +end; + procedure CallV(const RPCName: string; const AParam: array of const); { calls the broker leaving results in results property which must be read by caller } @@ -353,5 +368,5 @@ begin SavedCursor := Screen.Cursor; - Screen.Cursor := crHourGlass; + Screen.Cursor := GetRPCCursor; SetParams(RPCName, AParam); CallBroker; //RPCBrokerV.Call; @@ -365,5 +380,5 @@ begin SavedCursor := Screen.Cursor; - Screen.Cursor := crHourGlass; + Screen.Cursor := GetRPCCursor; SetParams(RPCName, AParam); CallBroker; //RPCBrokerV.Call; @@ -379,8 +394,8 @@ if ReturnData = nil then raise Exception.Create('TString not created'); SavedCursor := Screen.Cursor; - Screen.Cursor := crHourGlass; + Screen.Cursor := GetRPCCursor; SetParams(RPCName, AParam); CallBroker; //RPCBrokerV.Call; - ReturnData.Assign(RPCBrokerV.Results); + FastAssign(RPCBrokerV.Results, ReturnData); Screen.Cursor := SavedCursor; end; @@ -395,5 +410,5 @@ begin SavedCursor := Screen.Cursor; - Screen.Cursor := crHourGlass; + Screen.Cursor := GetRPCCursor; SetParams(RPCName, AParam); RPCBrokerV.Call; @@ -450,5 +465,5 @@ procedure LoadRPCData(Dest: TStrings; ID: Integer); begin - if (ID > -1) and (ID < uCallList.Count) then Dest.Assign(TStringList(uCallList.Items[ID])); + if (ID > -1) and (ID < uCallList.Count) then FastAssign(TStringList(uCallList.Items[ID]), Dest); end; Index: cprs/trunk/CPRS-Lib/ORSystem.pas =================================================================== --- cprs/trunk/CPRS-Lib/ORSystem.pas (revision 456) +++ cprs/trunk/CPRS-Lib/ORSystem.pas (revision 829) @@ -2,4 +2,5 @@ {$O-} +{$WARN SYMBOL_PLATFORM OFF} interface @@ -19,16 +20,4 @@ CPRS_LAST_DATE = 'Software\Vista\CPRS\DateUpdated'; - { values that can be passed to FileVersionValue } - FILE_VER_COMPANYNAME = '\StringFileInfo\040904E4\CompanyName'; - FILE_VER_FILEDESCRIPTION = '\StringFileInfo\040904E4\FileDescription'; - FILE_VER_FILEVERSION = '\StringFileInfo\040904E4\FileVersion'; - FILE_VER_INTERNALNAME = '\StringFileInfo\040904E4\InternalName'; - FILE_VER_LEGALCOPYRIGHT = '\StringFileInfo\040904E4\LegalCopyright'; - FILE_VER_ORIGINALFILENAME = '\StringFileInfo\040904E4\OriginalFilename'; - FILE_VER_PRODUCTNAME = '\StringFileInfo\040904E4\ProductName'; - FILE_VER_PRODUCTVERSION = '\StringFileInfo\040904E4\ProductVersion'; - FILE_VER_COMMENTS = '\StringFileInfo\040904E4\Comments'; - - function AppOutOfDate(AppName: string): Boolean; function ClientVersion(const AFileName: string): string; @@ -40,5 +29,4 @@ //procedure FileCopy(const FromFileName, ToFileName: string); //procedure FileCopyWithDate(const FromFileName, ToFileName: string); -function FileVersionValue(const AFileName, AValueName: string): string; function FullToFilePart(const AFileName: string): string; function FullToPathPart(const AFileName: string): string; @@ -60,4 +48,5 @@ procedure RunProgram(const AppName: string); function UpdateSelf: Boolean; +function BorlandDLLVersionOK: boolean; implementation @@ -110,5 +99,15 @@ // check for different file date in the gold directory GoldName := RegReadStr(CPRS_REG_GOLD); - if Length(GoldName) = 0 then Exit; + if (Length(GoldName) = 0) then exit; + if not DirectoryExists(GoldName) then + begin + if Pos('"', Goldname) > 0 then + begin + Goldname := Copy(GoldName, 2, MaxInt); + if Pos('"', Goldname) > 0 then + Goldname := Copy(GoldName, 1, Length(GoldName) - 1); + end; + end; + if (not DirectoryExists(GoldName)) then Exit; GoldName := GoldName + FullToFilePart(AppName); if FileExists(GoldName) then @@ -139,28 +138,4 @@ IntToStr(HIWORD(dwFileVersionLS)) + '.' + IntToStr(LOWORD(dwFileVersionLS)); - end; -end; - -function FileVersionValue(const AFileName, AValueName: string): string; -type - PValBuf = ^TValBuf; - TValBuf = array[0..255] of Char; -var - VerSize, ValSize, AHandle: DWORD; - VerBuf: Pointer; - ValBuf: PValBuf; -begin - Result := ''; - VerSize:=GetFileVersionInfoSize(PChar(AFileName), AHandle); - if VerSize > 0 then - begin - GetMem(VerBuf, VerSize); - try - GetFileVersionInfo(PChar(AFileName), AHandle, VerSize, VerBuf); - VerQueryValue(VerBuf, PChar(AValueName), Pointer(ValBuf), ValSize); - SetString(Result, ValBuf^, ValSize); - finally - FreeMem(VerBuf); - end; end; end; @@ -551,3 +526,36 @@ *) +function BorlandDLLVersionOK: boolean; +const + DLL_CURRENT_VERSION = 10; + TC_DLL_ERR = 'ERROR - BORLNDMM.DLL'; + TX_NO_RUN = 'This version of CPRS is unable to run because' + CRLF; + TX_NO_DLL = 'no copy of BORLNDMM.DLL can be found' + CRLF + + 'in your workstation''s current PATH.'; + TX_OLD_DLL1 = 'the copy of BORLNDMM.DLL located at:' + CRLF + CRLF; + TX_OLD_DLL2 = CRLF + CRLF + 'is out of date (Version '; + TX_CALL_IRM = CRLF + CRLF +'Please contact IRM for assistance.'; +var + DLLHandle: HMODULE; + DLLNamePath: array[0..261] of Char; + DLLVersion: string; +begin + Result := TRUE; + DLLHandle := GetModuleHandle('BORLNDMM.DLL'); + if DLLHandle <=0 then + begin + InfoBox(TX_NO_RUN + TX_NO_DLL + TX_CALL_IRM, TC_DLL_ERR, MB_ICONERROR or MB_OK); + Result := FALSE; + Exit; + end; + Windows.GetModuleFileName(DLLHandle, DLLNamePath, 261); + DLLVersion := ClientVersion(DLLNamePath); + if StrToIntDef(Piece(DLLVersion, '.', 1), 0) < DLL_CURRENT_VERSION then + begin + InfoBox(TX_NO_RUN + TX_OLD_DLL1 + ' ' + DLLNamePath + TX_OLD_DLL2 + DLLVersion + ')' + + TX_CALL_IRM, TC_DLL_ERR, MB_ICONERROR or MB_OK); + Result := false; + end; +end; + end. Index: cprs/trunk/CPRS-Lib/VA2006.dpk =================================================================== --- cprs/trunk/CPRS-Lib/VA2006.dpk (revision 829) +++ cprs/trunk/CPRS-Lib/VA2006.dpk (revision 829) @@ -0,0 +1,35 @@ +package VA2006; + +{$R *.res} +{$ALIGN 8} +{$ASSERTIONS OFF} +{$BOOLEVAL OFF} +{$DEBUGINFO ON} +{$EXTENDEDSYNTAX ON} +{$IMPORTEDDATA ON} +{$IOCHECKS ON} +{$LOCALSYMBOLS ON} +{$LONGSTRINGS ON} +{$OPENSTRINGS ON} +{$OPTIMIZATION ON} +{$OVERFLOWCHECKS ON} +{$RANGECHECKS ON} +{$REFERENCEINFO ON} +{$SAFEDIVIDE OFF} +{$STACKFRAMES ON} +{$TYPEDADDRESS OFF} +{$VARSTRINGCHECKS ON} +{$WRITEABLECONST ON} +{$MINENUMSIZE 1} +{$IMAGEBASE $400000} +{$DESCRIPTION 'Wrap Grid'} +{$DESIGNONLY} +{$IMPLICITBUILD ON} + +requires + vcl; + +contains + Vawrgrid in 'Vawrgrid.pas'; + +end. Index: cprs/trunk/CPRS-Lib/VA2006.drc =================================================================== --- cprs/trunk/CPRS-Lib/VA2006.drc (revision 829) +++ cprs/trunk/CPRS-Lib/VA2006.drc (revision 829) @@ -0,0 +1,14 @@ +/* VER180 + Generated by the Borland Delphi Pascal Compiler + because -GD or --drc was supplied to the compiler. + + This file contains compiler-generated resources that + were bound to the executable. + If this file is empty, then no compiler-generated + resources were bound to the produced executable. +*/ + +STRINGTABLE +BEGIN +END + Index: cprs/trunk/CPRS-Lib/sqasrvr.pas =================================================================== --- cprs/trunk/CPRS-Lib/sqasrvr.pas (revision 829) +++ cprs/trunk/CPRS-Lib/sqasrvr.pas (revision 829) @@ -0,0 +1,1702 @@ + {************************************************************************* + * + * Copyright 2000 - 2004 Rational Software Corporation. All Rights Reserved. + * This software contains proprietary and confidential information of Rational + * and its suppliers. Use, disclosure or reproduction is prohibited + * without the prior express written consent of Rational. + * + * Name: sqasrvr.pas + * Description: + * + * Revision History: + * Programmer Date Description + * sraj 05/18/2004 Fixed Delphi 5 compilation issues. + * sraj 07/25/2003 Supported TTreeView items collection in properties. + * sraj 07/25/2003 Supported TStringGrid object data. + * sraj 24/04/2003 RATLC00447073: Included FindControl1() to lookup delphi object + * given a window handle effectively. + * sraj 10/03/2002 RATLC00436896, RATLC00052492 : Included BeautifyApplicationWindow + * sraj 06/23/2003 RATLC00449186 : Exception trace enabled using a Registry key. + * sraj 10/03/2002 RATLC00436896, RATLC00052492 : Included BeautifyApplicationWindow + * to make application object available as a window property. + * Removed the call RegisterAutomationServer() from unit Initialization. + * PBeaulieu 01/08/2002 Changed TPublishedAutoDispatch.NewDispatch to set the found + * flag if found in first case to bypass the second search method. + * PBeaulieu 08/20/2001 Changed TIObjectDispatch.GetProperty inorder to make + * sure that Unassigned Variant or incorrect Variant type + * would not be used in retrieving a property. Changed + * TPublishedAutoDispatch.NewDispatch to search manually the + * inheritance hierarchy if InheritsFrom fails. This allows + * for objects that the InheritsFrom function fails on + * seemingly because it cannot access the information with + * the functions it is using. This seemed to happen with + * MDI app where the MDI children were created from another + * dll that encapsulated the form in another object. + * PBeaulieu 06/26/01 Merged in Pete Ness's changes to fix some warnings and + * to add some logging for exceptions. Also, added the function + * TIObjectDispatch.ParentClassName. + * PMNess 05/16/01 Changed the "Classname" calls in TPublishedAutoDispatch + * to FObject.Classname - as Classname was always + * returning TPublishedAutoDispatch instead of + * the actual invoked class. + * PMNess 05/15/01 Updated and removed hints/warnings under D5 + * Added try/excepts around all automated calls + * to trap exceptions that may happen and log to + * file. + * KPATEL 05/25/00 Replaced the function 'VarAsType' with + * 'VarToStr' as Delphi 5 takes only string as + * the third parameter in SetStrProp function. + * SJPak 03/31/98 Modified TIObjectDispatch.GetEnumList to + * return empty variant when the total length of + * the strings for enumerated choices exceed + * 2047. This is to keep Robot from crashing + * Robot cannot handle more 2048 characters total. + * SJPak 04/02/97 Modified TPublishedAutoDispatch.Invoke to + * support TColor type properties. + * SJPak 08/04/96 Added additional interface TIStringGridDispatch + * to support Cols and Rows properties of TStringGrid. + * SJPak 03/06/97 Modified TICollectionDispatch.GetPropNames + * and TICollectionDispatch.GetProperty to support + * Items property. + * SJPak 11/21/96 Replacing calls to OLECheck which + * will raise an exception when return value + * is less than 0. Raising an exception + * will cause a messagebox to pop up when ran + * from Delphi IDE. + * SJPak 11/15/96 Fixed a memory leak in + * TIObjectDispatch.SetProperty + * SJPak 11/11/96 Modified TIStringsDispatch.GetProperty + * to check for empty "Strings" property. + * SJPak 11/07/96 Removed calls to OleError to prevent + * error messages being displayed during + * Rec/Plaback session through IDE. + * SJPak 10/07/96 Modified TIStringsDispatch to support + * Strings property of TStrings object. + * SJPak 09/19/96 Changed CLSID of the server. + * SJPak 08/04/96 Added additional interface TIOleControlDispatch + * to support OCXs. + * SJPak 08/01/96 Modified TPublishedAutoDispatch.Invoke + * to return tkSet type properties as + * a safe array of Variants containing + * names of all possible items in the set + * and booleans representing whether the items + * are in the particular set. + * SJPak 07/31/96 Fixed Borland's bug in + * TPublishedAutoDispatch.Invoke function's + * handling of min and max values of + * tkSet properties. + * SJPak 07/18/96 Changed Unit name to SQASrvr + * SJPak 07/18/96 Added addtional interface TIStringsDispatch + * to support TStrings class. + * SJPak 07/18/96 Added GetPropNames and GetProeprty to + * TICollectionDispatch. + * SJPak 07/18/96 Added GetPropNames method to TIObjectDispatch + * interface. + * SJPak 07/08/96 Added SetProperty method to TIObjectDispatch + * interface. + * SJPak 07/08/96 Additional interface define for + * DatSet Objects. + * SJPak 07/01/96 Fixed a bug in TPublishedAutoDispatch.Invoke + * SJPak 07/01/96 Additional interface defined for + * collections. + * SJPak 07/01/96 Original From Delphi. + * + **************************************************************************} + unit SQASrvr; + + interface + + uses + Windows, + {$IFDEF VER140} + Variants, + {$ENDIF} + {$IFDEF VER150} + Variants, + {$ELSE} //Added for Delphi 2006 + Variants, //Added for Delphi 2006 + {$ENDIF} + OleAuto, + OLE2, TypInfo, DB, DBTables, OleCtrls, Grids, Controls, Registry, ComCtrls; + const + AutoClassExistsMsg = 'Automation enabler for class %s is already registered'; + + { FirstComponentIndex needs to be high enough so that it doesn't conflict with + the DispIDs of the TAutoObject. The "automated" properties and methods have + DispIDs starting with 1 in the base object and incrementing by one from + there. } + FirstComponentIndex = $000000FF; + LastComponentIndex = $0000FFFE; + FirstPropIndex = $0000FFFF; + LastPropIndex = $7FFFFFFF; { maxint } + + // Arbitrary Max for each element of TStrings.Strings property. + MaxStringItem = 32000; + + type + { SJP Todo: This limits the set range from 0 - 15. + According to Doc. Set can have upto 256 elements } + TCardinalSet = set of 0..SizeOf(Cardinal) * 8 - 1; + // TCardinalSet = set of 0..255; + + { TPublishedAutoDispatch } + + TPublishedAutoDispatch = class(TAutoDispatch) + private + FObject: TObject; + public + constructor Create(AutoObject: TAutoObject; BoundObj: TObject); + procedure NewDispatch(var V: Variant; Obj: TObject); + function GetIDsOfNames(const iid: TIID; rgszNames: POleStrList; + cNames: Integer; lcid: TLCID; rgdispid: PDispIDList): HResult; override; + function Invoke(dispIDMember: TDispID; const iid: TIID; lcid: TLCID; + flags: Word; var dispParams: TDispParams; varResult: PVariant; + excepInfo: PExcepInfo; argErr: PInteger): HResult; override; + end; + + { TIObjectDispatch } + + TIObjectDispatch = class(TAutoObject) + private + procedure GetProps(var v: Variant; TypeKinds: TTypeKinds); + protected + FObject: TObject; + function CreateAutoDispatch: TAutoDispatch; override; + // 5/16/2001 - PMNess - Added new GetExceptionInfo to log any + // exception on the invoke to a log file. This works generically when anything + // is called... + procedure GetExceptionInfo(ExceptObject: TObject; + var ExcepInfo: TExcepInfo); override; + public + constructor Connect(Obj: TObject); virtual; + automated + function ClassName: String; + function GetProperty(PropName: String): Variant; + function GetObject(ObjName: String): Variant; + procedure GetEnumList(PropName: String; var v: Variant); + procedure GetProperties(var v: Variant); + procedure GetObjects(var v: Variant); + function InheritsFrom(AClass: String): WordBool; + // SJP: 07/09/96 Added SetProperty. + function SetProperty(PropName: String; var v: Variant): WordBool; + // SJP: 07/18/96 Added SetProperty. + procedure GetPropNames(var v: Variant); + //PBeaulieu: 05/22/2001 Added ParentClassName + function ParentClassName: String; + end; + + { TIComponentDispatch } + + TIComponentDispatch = class(TIObjectDispatch) + private + function GetComponents(Index: Integer): Variant; + function GetComponentCount: Integer; + function GetComponentIndex: Integer; + function GetOwner: Variant; + protected // 5-16-2001 - Added protected to get rid of hint on GetDesignInfo + function GetDesignInfo: LongInt; + automated + property Components[Index: Integer]: Variant read GetComponents; + property ComponentCount: Integer read GetComponentCount; + property ComponentIndex: Integer read GetComponentIndex; + property Owner: Variant read GetOwner; + function FindComponent(AName: String): Variant; + end; + + { TIControlDispatch } + + TIControlDispatch = class(TIComponentDispatch) + private + function GetParent: Variant; + automated + property Parent: Variant read GetParent; + end; + + { TIWinControlDispatch } + + TIWinControlDispatch = class(TIControlDispatch) + private + function GetHandle: Integer; + function GetControls(Index: Integer): Variant; + function GetControlCount: Integer; + automated + property Handle: Integer read GetHandle; + property Controls[Index: Integer]: Variant read GetControls; + property ControlCount: Integer read GetControlCount; + function ControlAtPos(X, Y: Integer): Variant; + end; + + { TIApplicationDispatch } + + TIApplicationDispatch = class(TIComponentDispatch) + private + function GetHandle: Integer; + function GetMainForm: Variant; + function GetExeName: String; + function FindControl1(hWndToFind: HWnd): TWinControl; + public + constructor Create; override; + automated + property Handle: Integer read GetHandle; + property MainForm: Variant read GetMainForm; + property ExeName: String read GetExeName; + function GetDispFromHandle(Handle: Integer): Variant; + end; + + // SJP 07/01/96 Additional interface defined for collections + { TICollectionDispatch } + + TICollectionDispatch = class(TIObjectDispatch) + private + function GetItemCount: Integer; + automated + property ItemCount: Integer read GetItemCount; + procedure GetPropNames(var v: Variant); + function GetProperty(PropName: String): Variant; + end; + + // SJP 07/08/96 Additional interface defined for 'dataset' objects. + { TIDataSetDispatch } + + TIDataSetDispatch = class(TIObjectDispatch) + private + function GetFieldCount: Integer; + automated + property FieldCount: Integer read GetFieldCount; + function GetData: String; + end; + + // SJP 07/18/96 Additional interface defined for TStrings Objects + { TIStringsDispatch } + + TIStringsDispatch = class(TIObjectDispatch) + automated + function GetProperty(PropName: String): Variant; + procedure GetPropNames(var v: Variant); + end; + + // SJP 08/03/96 Addition interface defined for TOleControl(OCX) Component + TIOleControlDispatch = class(TIWinControlDispatch) + private + function GetOleObject: Variant; + automated + property OleObject: Variant read GetOleObject; + end; + + // SJP 03/10/97 Addition interface defined for TStringGrid Component + TIStringGridDispatch = class(TIWinControlDispatch) + automated + function GetProperty(PropName: String): Variant; + procedure GetPropNames(var v: Variant); + function GetData: String; + end; + + // Addition interface defined for TTreeView Component + TITreeViewDispatch = class(TIWinControlDispatch) + automated + function GetProperty(PropName: String): Variant; + procedure GetPropNames(var v: Variant); + end; + + { Support functions} + + TIObjectDispatchRef = class of TIObjectDispatch; + + PClassMapRecord = ^TClassMapRecord; + TClassMapRecord = record + ObjectClass: TClass; + DispClass: TIObjectDispatchRef; + end; + + procedure FreeClassLists; + + procedure RegisterAutomationEnabler( ObjectClass: TClass; + DispClass: TIObjectDispatchRef); + + implementation + + uses Forms, Classes, SysUtils; + + var + ClassMap: TList = nil; + + // Called when any exception is raised from this COM object. Logs the + // error to a log file. + procedure WriteToLog(ErrorMsg: String); + var + LogFile: TextFile; + LogFileName: String; + begin // AddToErrorLog + try + LogFileName := ExtractFilePath(ParamStr(0))+'\Robot Errors for '+ExtractFileName(ParamStr(0))+'.log'; + AssignFile(LogFile, LogFileName); + if (FileExists(LogFileName)) + then Append(LogFile) + else Rewrite(LogFile); + try + Writeln(LogFile, DateTimeToStr(Now)+' '+ErrorMsg); + finally + CloseFile(LogFile); + end; + except + // Supress this - as we're likely in some kind of error log already! + end; + end; + + function IsExceptionTraceEnabled( ) : Boolean; + var + Reg: TRegistry; + deTrace: string; + begin + Result := False; + Reg := TRegistry.Create; + try + Reg.RootKey := HKEY_CURRENT_USER; + if Reg.OpenKey('Software\Rational Software\Rational Test\8\Robot', False) then + begin + deTrace := Reg.ReadString( 'DelphiExceptionTrace' ); + if ( (deTrace = '1') or ( LowerCase(deTrace) = 'true' ) ) then + begin + Result := True; + end; + + Reg.CloseKey; + end; + finally + Reg.Free; + end; + end; + + { Exit procedure used to free memory used by the ClassList } + procedure FreeClassLists; + var + I: Integer; + begin + for I := 0 to ClassMap.Count-1 do + Dispose(PClassMapRecord(ClassMap[I])); + ClassMap.Free; + end; + + { This is called in the initialization section of a unit for all new + automation objects. It associates an AutoObject with a VCL class. } + procedure RegisterAutomationEnabler(ObjectClass: TClass; + DispClass: TIObjectDispatchRef); + var + P: PClassMapRecord; + X: Integer; + Found: Boolean; + begin + if not Assigned(ClassMap) then + begin + AddExitProc(FreeClassLists); + ClassMap := TList.Create; + end; + Found := False; + for X := 0 to ClassMap.Count-1 do + begin + P := PClassMapRecord(ClassMap[x]); + if ObjectClass.InheritsFrom(P^.ObjectClass) then + if ObjectClass = P^.ObjectClass then + raise Exception.CreateFmt(AutoClassExistsMsg,[ObjectClass.ClassName]) + else + begin + Found := True; + break; + end; + end; + New(P); + P^.ObjectClass := ObjectClass; + P^.DispClass := DispClass; + if Found then + { ObjectClass is a descendent of P^.ObjectClass, so insert the descendent + into the class list in front of the ancestor. } + ClassMap.Insert(X,P) + else + { ObjectClass is not related to any classes already in the list, so just add + it to the end of the list. } + ClassMap.Add(P); + end; + + { TPublishedAutoDispatch } + + constructor TPublishedAutoDispatch.Create(AutoObject: TAutoObject; BoundObj: TObject); + begin + inherited Create(AutoObject); + FObject := BoundObj; + end; + + { NewDispatch is called to create an AutoObject bound to a VCL object. + Example: when the controller calls Application.MainForm.Button1.Caption, + NewDispatch would be called to return the dispatches for MainForm and + Button1. Not called directly by the controller. } + procedure TPublishedAutoDispatch.NewDispatch(var V: Variant; Obj: TObject); + var + i: Integer; + P: PClassMapRecord; + Found: Boolean; + Cls: TClass; + begin + VarClear(V); + Found := FALSE; + if not (Assigned(Obj) and Assigned(ClassMap)) then Exit; + for i := 0 to ClassMap.Count - 1 do + begin + P := PClassMapRecord(ClassMap[i]); + if Obj.InheritsFrom(P^.ObjectClass) then + begin + V := P^.DispClass.Connect(Obj).OleObject; + { Do a release here because the Connect does an AddRef and the + OleObject does an AddRef, we only want 1. } + VarToInterface(V).Release; + Found := TRUE; + break; + end; + end; + + if Found = FALSE then + begin + for i := 0 to ClassMap.Count - 1 do + begin + P := PClassMapRecord(ClassMap[i]); + + if Obj.ClassName = P^.ObjectClass.ClassName then + begin + V := P^.DispClass.Connect(Obj).OleObject; + { Do a release here because the Connect does an AddRef and the + OleObject does an AddRef, we only want 1. } + VarToInterface(V).Release; + break; + end; + + Cls := Obj.ClassParent; + + while( Cls <> nil ) do + begin + if Cls.ClassName = P^.ObjectClass.ClassName then + begin + V := P^.DispClass.Connect(Obj).OleObject; + { Do a release here because the Connect does an AddRef and the + OleObject does an AddRef, we only want 1. } + VarToInterface(V).Release; + Found := TRUE; + break; + end; + Cls := Cls.ClassParent; + end; + + if Found = TRUE then + begin + break; + end; + end; + end; + end; + + { Searches through the published properties of the associated object for the + requested name (property). If it is not found it calls the inherited + GetIDsOfNames which will then search through the TAutoObject's "automated" + section for the name. } + function TPublishedAutoDispatch.GetIDsOfNames(const iid: TIID; rgszNames: POleStrList; + cNames: Integer; lcid: TLCID; rgdispid: PDispIDList): HResult; + var + PropName: string; + SubComponent: TComponent; + begin + if cNames <> 1 then + begin + Result := inherited GetIDsOfNames(iid, rgszNames, cNames, lcid, rgdispid); + Exit; + end; + Result := DISP_E_UNKNOWNNAME; + PropName := WideCharToString(rgszNames^[0]); + rgdispid^[0] := TDISPID(GetPropInfo(FObject.ClassInfo, PropName)); + if rgdispid^[0] <> 0 then + begin + if PPropInfo(rgdispid^[0])^.PropType^.Kind in [tkInteger, tkEnumeration, + tkString, tkFloat, tkClass, tkSet, tkMethod, tkLString{, tkLWString}] then + Result := S_OK; + end + else if FObject is TComponent then + begin + SubComponent := TComponent(FObject).FindComponent(PropName); + if SubComponent <> nil then + begin + rgdispid^[0] := FirstComponentIndex + TDispID(SubComponent.ComponentIndex); + Result := S_OK; + end; + end; + { Pass to inherited if nothing resolves the call. } + if Result <> S_OK then + Result := inherited GetIDsOfNames(iid, rgszNames, cNames, lcid, rgdispid); + end; + + { Gets a property or calls a method of the associated object. If the + dispIDMember is less than FirstComponentIndex it should be in the AutoObject, + otherwise it attempts to find the request in the published section of the + associated object. } + function TPublishedAutoDispatch.Invoke(dispIDMember: TDispID; const iid: TIID; lcid: TLCID; + flags: Word; var dispParams: TDispParams; varResult: PVariant; + excepInfo: PExcepInfo; argErr: PInteger): HResult; + var + PropInfo: PPropInfo; + W: Cardinal; + TypeInfo: PTypeInfo; + TypeData: PTypeData; + ErrorMessage: String; + I: Integer; + J: Integer; + // SetItemString: String; + begin + Result := DISP_E_MEMBERNOTFOUND; + PropInfo := NIL; + try + { If it is a component then call NewDispatch to return the IDispatch to + the controller } + if (dispIDMember >= FirstComponentIndex) and + (dispIDMember <= LastComponentIndex) then + begin + NewDispatch(VarResult^,TComponent(FObject).Components[dispIDMember - FirstComponentIndex]); + Result := S_OK; + end + { Check to see if it is a property } + else if (dispIDMember >= FirstPropIndex) then + // and (dispIDMember <= LastPropIndex) 5-16-2001 Removed - as this is always true + begin + PropInfo := PPropInfo(dispIDMember); + if Flags and DISPATCH_PROPERTYGET <> 0 then //Only Get Property + begin + VarClear(VarResult^); + Result := S_OK; + case PropInfo^.PropType^.Kind of + tkInteger: + begin + VarResult^ := GetOrdProp(FObject, PropInfo); + // SJP: 04/02/97 Modifying original. + // Set a flag to indicate Color property. + if PropInfo^.PropType^.Name = 'TColor' then + begin + TVariantArg(VarResult^).wReserved1 := 8; + end; + end; + tkEnumeration: + // SJP: 07/10/96 Modifying original. + // Now tkEnumeration properties will + // be returned as VT_I2; + begin + //TVariantArg(VarResult^).vt := VT_BSTR; + //TVariantArg(VarResult^).bstrVal := StringToOleStr( + //GetEnumName(PropInfo^.PropType, GetOrdProp(FObject, PropInfo))); + TVariantArg(VarResult^).vt := VT_I2; + TVariantArg(VarResult^).iVal := GetOrdProp(FObject, PropInfo); + end; + tkFloat: + VarResult^ := GetFloatProp(FObject, PropInfo); + tkString: + VarResult^ := GetStrProp(FObject, PropInfo); + tkSet: + begin + // SJP: 07/31/96 Modifying the original. + // Changing to return a safe array of Variants containing + // Names of all possible items in the set + // and booleans representing whether the items are + // in this particular set. + // SetItemString := '['; + W := GetOrdProp(FObject, PropInfo); + {$IFDEF VER90} + TypeData := GetTypeData(PropInfo^.PropType); + TypeInfo := TypeData^.CompType; + {$ELSE} + TypeData := GetTypeData(PropInfo^.PropType^); + TypeInfo := TypeData^.CompType^; + {$ENDIF} + // SJP: 07/31/96 Modifying the original Borland code. + // Get the TypeData again from the TypeInfo + // TypeInfo represents the OrdType of the set. + // the new TypeData will have correct MinValue and MaxValue. + TypeData := GetTypeData(TypeInfo); + VarResult^ := VarArrayCreate([0, TypeData^.MaxValue - TypeData^.MinValue, 0, 1], varVariant); + J := 0; + for I := TypeData^.MinValue to TypeData^.MaxValue do + begin + VarResult^[J, 0] := GetEnumName(TypeInfo, I); + if I in TCardinalSet(W) then + VarResult^[J, 1] := True + else + VarResult^[J, 1] := False; + J := J + 1; + end; + // begin + // if Length(SetItemString) <> 1 then + // SetItemString := SetItemString + ','; + // SetItemString := SetItemString + GetEnumName(TypeInfo, I); + // end; + // SetItemString := SetItemString + ']'; + // TVariantArg(VarResult^).vt := VT_BSTR; + // TVariantArg(VarResult^).bstrVal := StringToOleStr(SetItemString); + end; + tkClass: + NewDispatch(VarResult^, TObject(GetOrdProp(FObject, PropInfo))); + tkLString: + begin + TVariantArg(VarResult^).vt := VT_BSTR; + TVariantArg(VarResult^).bstrVal := StringToOleStr(GetStrProp(FObject, PropInfo)); + end; + else + Result := E_NOTIMPL; + end; + end + else if Flags and DISPATCH_PROPERTYPUT <> 0 then + begin + Result := S_OK; + case PropInfo^.PropType^.Kind of + tkInteger: + SetOrdProp(FObject, PropInfo, VarAsType(Variant(dispParams.rgvarg[0]),varInteger)); + tkString: + // KPATEL: Replaced the function 'VarAsType' with 'VarToStr' as Delphi 5 + // takes only string as the third parameter in SetStrProp function. + // SetStrProp(FObject, PropInfo, VarAsType(Variant(dispParams.rgvarg[0]),varString)); + SetStrProp(FObject, PropInfo, VarToStr(Variant(dispParams.rgvarg[0]))); + tkLString: + // KPATEL: Replaced the function 'VarAsType' with 'VarToStr' as Delphi 5 + // takes only string as the third parameter in SetStrProp function. + // SetStrProp(FObject, PropInfo, VarAsType(Variant(dispParams.rgvarg[0]),varString)); + SetStrProp(FObject, PropInfo, VarToStr(Variant(dispParams.rgvarg[0]))); + tkEnumeration: + SetOrdProp(FObject, PropInfo, VarAsType(Variant(dispParams.rgvarg[0]),varSmallInt)); + tkFloat: + SetFloatProp(FObject, PropInfo, VarAsType(Variant(dispParams.rgvarg[0]),varSingle)); + { tkSet: + begin + SetItemString := '['; + W := GetOrdProp(FObject, PropInfo); + TypeData := GetTypeData(PropInfo^.PropType); + TypeInfo := TypeData^.CompType; + // SJP: Commented out because TypeData^.MinValue/MaxValue is + // bogus. + // ShowMessage(IntToStr(TypeData^.MinValue)); + // ShowMessage(IntToStr(TypeData^.MaxValue)); + // for I := TypeData^.MinValue to TypeData^.MaxValue do + for I := 0 to 255 do + if I in TCardinalSet(W) then + begin + if Length(SetItemString) <> 1 then + SetItemString := SetItemString + ','; + SetItemString := SetItemString + GetEnumName(TypeInfo, I); + end; + SetItemString := SetItemString + ']'; + TVariantArg(VarResult^).vt := VT_BSTR; + TVariantArg(VarResult^).bstrVal := StringToOleStr(SetItemString); + end;} + else + Result := E_NOTIMPL; + end; + end; + end; + { If not found then pass it to the TAutoDispatch.Invoke method. } + if Result <> S_OK then + begin + Result := inherited Invoke(dispIDMember, iid, lcid, flags, dispParams, + varResult, excepInfo, argErr); + end + except + on E:Exception + do begin + ErrorMessage := FObject.ClassName; + if (Assigned(PropInfo)) then ErrorMessage := ErrorMessage + '.' + PropInfo.Name; + + if ExcepInfo <> nil then + begin + FillChar(ExcepInfo^, 0, SizeOf(TExcepInfo)); + //Copied this from TAutoObject.GetExceptionInfo + with ExcepInfo^ do + begin + bstrSource := StringToOleStr(FObject.ClassName); + if ExceptObject is Exception then + begin + bstrDescription := StringToOleStr(Exception(ExceptObject).Message); + ErrorMessage := ErrorMessage + ': ' + Exception(ExceptObject).Message; + end + else ErrorMessage := ErrorMessage + ': ' + E.Message; + scode := E_FAIL; + end; + end + else ErrorMessage := ErrorMessage + ': ' + E.Message; + + WriteToLog(ErrorMessage); + Result := DISP_E_EXCEPTION; + end; + end; + end; + + { TIObjectDispatch } + + { Obj is the Object that is being "Bound" to here. This AutoObject will then + surface properties for Obj. } + constructor TIObjectDispatch.Connect(Obj: TObject); + begin + FObject := Obj; + inherited Create; + end; + + function TIObjectDispatch.CreateAutoDispatch: TAutoDispatch; + begin + Result := TPublishedAutoDispatch.Create(Self, FObject); + end; + + // New override to trap exceptions raised in the invoke. + // 5/16/2001 - PMNess + procedure TIObjectDispatch.GetExceptionInfo(ExceptObject: TObject; + var ExcepInfo: TExcepInfo); + begin + try + if (ExceptObject is Exception) then + begin + WriteToLog(PChar(Exception(ExceptObject).Message)); + end; + except + // 5/16/2001 - PMNess + // If the exception object has a problem, we don't want to cause another + // exception here, so just mask it. + end; + inherited; + end; + + function TIObjectDispatch.ClassName: String; + begin + Result := FObject.ClassName; + end; + + function TIObjectDispatch.ParentClassName: String; + var + P: TClass; + ClassNames: String; + begin + P := FObject.ClassParent; + ClassNames := ''; + + while( P <> nil ) do + begin + if Length(ClassNames) > 0 then + begin + ClassNames := ClassNames + ','; + end; + + ClassNames := ClassNames + P.ClassName; + + P := P.ClassParent; + end; + + Result := ClassNames; + end; + + function TIObjectDispatch.InheritsFrom(AClass: String): WordBool; + var + P: TClass; + begin + P := FObject.ClassType; + while (P <> nil) and (CompareText(P.ClassName, AClass) <> 0) do + P := P.ClassParent; + Result := P <> nil; + end; + + { Just a friendly wrapper around GetProperty for ease of use } + function TIObjectDispatch.GetObject(ObjName: String): Variant; + begin + Result := GetProperty(ObjName); + end; + + { GetProperty can take a full path to a property or object + (ie Form1.Button1.Caption) and return the value of the property or object + as a variant. } + function TIObjectDispatch.GetProperty(PropName: String): Variant; + var + Params: TDispParams; + Index: TDISPID; + ExpInfo: TEXCEPINFO; + ArgErr: Integer; + PWStr: PWideChar; + Name: String; + Idx: Integer; + Holder: Variant; + guid: TGUID; + begin + FillChar(Params,SizeOf(Params),0); + FillChar(ExpInfo,SizeOf(ExpInfo),0); + ArgErr := 0; + Idx := Pos('.', PropName); + if Idx > 0 then + begin + Name := Copy(PropName,1,Idx - 1); + Delete(PropName,1,Idx); + end + else + Name := PropName; + PWStr := StringToOleStr(Name); + + // 11/21/96 SJPak Replacing calls to OLECheck which will raise an exception + // when return value is less than 0. Raising an exception + // will cause a messagebox to pop up when ran from IDE. + if AutoDispatch.GetIDsOfNames(guid, @PWStr, 1, 0, @Index) >= 0 then + if AutoDispatch.Invoke(Index, guid, 0, Dispatch_PropertyGet or Dispatch_Method, + Params, @Holder, @ExpInfo, @ArgErr) >= 0 then + if VarType(Holder) = varDispatch then + VarToInterface(Holder).AddRef; + + SysFreeString(PWStr); + + if ( not VarIsEmpty( Holder ) ) and ( VarType( Holder ) = varDispatch ) and ( Idx > 0 ) then + begin + Result := Holder.GetProperty(PropName); + VarToInterface(Holder).Release; + VarClear(Holder); + end + else if ( VarIsEmpty( Holder ) ) then + begin + Holder := NULL; + // VarClear( Holder ); + Result := Holder; + end + else + Result := Holder; + end; + + procedure TIObjectDispatch.GetProps(var v: Variant; TypeKinds: TTypeKinds); + var + I, J, Count: Integer; + PropInfo: PPropInfo; + TempList: PPropList; + SetItemString: String; + W: Cardinal; + begin + Count := GetPropList(FObject.ClassInfo, TypeKinds, nil); + if Count > 0 then + begin + v := VarArrayCreate([0, Count - 1, 0, 2], varVariant); + GetMem(TempList, Count * SizeOf(Pointer)); + try + GetPropList(FObject.ClassInfo, TypeKinds, TempList); + for I := 0 to Count - 1 do + begin + PropInfo := TempList^[I]; + v[i,2] := PropInfo^.PropType^.Kind; + case PropInfo^.PropType^.Kind of + tkClass: + begin + v[i,0] := PropInfo^.Name; + v[i,1] := '(' + PropInfo^.PropType^.Name + ')'; + end; + tkString, + tkLString: + begin + v[i,0] := PropInfo^.Name; + v[i,1] := GetStrProp(FObject,PropInfo); + end; + tkChar: + begin + v[i,0] := PropInfo^.Name; + v[i,1] := Chr(GetOrdProp(FObject,PropInfo)); + if IsCharAlpha(Chr(GetOrdProp(FObject,PropInfo))) then + v[i,1] := Chr(GetOrdProp(FObject,PropInfo)) + else + v[i,1] := '#' + IntToStr(GetOrdProp(FObject,PropInfo)); + end; + tkInteger: + begin + v[i,0] := PropInfo^.Name; + v[i,1] := IntToStr(GetOrdProp(FObject,PropInfo)); + end; + tkFloat: + begin + v[i,0] := PropInfo^.Name; + v[i,1] := FloatToStr(GetFloatProp(FObject,PropInfo)); + end; + tkEnumeration: + begin + v[i,0] := PropInfo^.Name; + {$IFDEF VER90} + v[i,1] := GetEnumName(PropInfo^.PropType, GetOrdProp(FObject, PropInfo)); + {$ELSE} + v[i,1] := GetEnumName(PropInfo^.PropType^, GetOrdProp(FObject, PropInfo)); + {$ENDIF} + end; + tkSet: + begin + v[i,0] := PropInfo^.Name; + SetItemString := '['; + W := GetOrdProp(FObject, PropInfo); + for J := 0 to 15 do + if J in TCardinalSet(W) then + begin + if Length(SetItemString) <> 1 then + SetItemString := SetItemString + ','; + SetItemString := SetItemString + + {$IFDEF VER90} + GetEnumName(GetTypeData(PropInfo^.PropType)^.CompType, J); + {$ELSE} + GetEnumName(GetTypeData(PropInfo^.PropType^)^.CompType^, J); + {$ENDIF} + end; + SetItemString := SetItemString + ']'; + v[i,1] := SetItemString; + end; + tkVariant: + try + v[i,0] := PropInfo^.Name; + v[i,1] := VarAsType(GetVariantProp(FObject,PropInfo), varString); + except + v[i,1] := '(Variant)'; + end; + //None of these area implemented... + // tkWChar: + // tkLWString: + // tkUnknown: + // tkMethod: + end; + end; + finally + FreeMem(TempList, Count * SizeOf(Pointer)); + end; + end; + end; + + procedure TIObjectDispatch.GetProperties(var v: Variant); + const + TypeKinds: TTypeKinds = [{tkUnknown,} tkInteger, tkChar, tkEnumeration, tkFloat, + tkString, tkSet, tkClass, {tkMethod, }{tkWChar, }tkLString, {tkLWString,} + tkVariant]; + begin + GetProps(v, TypeKinds); + end; + + procedure TIObjectDispatch.GetObjects(var v: Variant); + begin + GetProps(v, [tkClass]); + end; + + { Given the property name this will return an array containing the possible + values of an enum. } + procedure TIObjectDispatch.GetEnumList(PropName: String; var v: Variant); + var + Name: String; + Idx: Integer; + Obj: Variant; + I, J: Integer; + TotalLength: Integer; + PropInfo: PPropInfo; + TypeData: PTypeData; + begin + Idx := Length(PropName); + while (Idx > 0) and (PropName[Idx] <> '.') do + Dec(Idx); + if Idx > 0 then + begin + Name := PropName; + Delete(Name,1,Idx); + Obj := GetProperty(Copy(PropName,1,Idx - 1)); + try + Obj.GetEnumList(Name,v); + finally + VarToInterface(Obj).Release; + end; + end + else + begin + PropInfo := GetPropInfo(FObject.ClassInfo,PropName); + if PropInfo^.PropType^.Kind <> tkEnumeration then + raise EOleSysError(DISP_E_TYPEMISMATCH); + {$IFDEF VER90} + TypeData := GetTypeData(PropInfo^.PropType); + {$ELSE} + TypeData := GetTypeData(PropInfo^.PropType^); + {$ENDIF} + j := TypeData^.MaxValue - TypeData^.MinValue; + v := VarArrayCreate([0, j], varVariant); + j := 0; + TotalLength := 0; + for i := TypeData^.MinValue to TypeData^.MaxValue do + begin + {$IFDEF VER90} + v[j] := GetEnumName(PropInfo^.PropType,i); + {$ELSE} + v[j] := GetEnumName(PropInfo^.PropType^,i); + {$ENDIF} + TotalLength := TotalLength + Length(v[j]) + 1; + Inc(j); + end; + + // SJP 3/31/98 Temporary fix to allow buffer overwrite in 6.1 SQAXDEL.DLL + if TotalLength > 2047 then + begin + v := UnAssigned; + end; + + end; + end; + + // SJP: 07/09/96 Added SetProperty. + function TIObjectDispatch.SetProperty(PropName: String; var v: Variant): WordBool; + var + Params: TDispParams; + Index: TDISPID; + ExpInfo: TEXCEPINFO; + ArgErr: Integer; + PWStr: PWideChar; + Name: String; + Idx: Integer; + Obj: Variant; + guid: TGUID; + bSuccess: WordBool; + begin + bSuccess := True; + // Separate the last property from the full path name. + Idx := Length(PropName); + while (Idx > 0) and (PropName[Idx] <> '.') do + Dec(Idx); + if Idx > 0 then + begin + Name := PropName; + Delete(Name,1,Idx); + Obj := GetProperty(Copy(PropName,1,Idx - 1)); + try + bSuccess := Obj.SetProperty(Name,v); + finally + VarToInterface(Obj).Release; + end; + end + else + begin + FillChar(Params,SizeOf(Params),0); + FillChar(ExpInfo,SizeOf(ExpInfo),0); + ArgErr := 0; + PWStr := StringToOleStr(PropName); + New(Params.rgvarg); + Params.rgvarg[0] := TVariantArg(v); + params.cArgs := 1; + + // 11/21/96 SJPak Replacing calls to OLECheck which will raise an exception + // when return value is less than 0. Raising an exception + // will cause a messagebox to pop up when ran from IDE. + if AutoDispatch.GetIDsOfNames(guid, @PWStr, 1, 0, @Index) >= 0 then + begin + if AutoDispatch.Invoke(Index, guid, 0, Dispatch_PropertyPut, + Params, nil, @ExpInfo, @ArgErr) < 0 then + bSuccess := False; + end + else + bSuccess := False; + + SysFreeString(PWStr); + Dispose(params.rgvarg); + end; + Result := bSuccess; + end; + + // SJP: 07/18/96 Added. + procedure TIObjectDispatch.GetPropNames(var v: Variant); + const + TypeKinds: TTypeKinds = [{tkUnknown,} tkInteger, tkChar, tkEnumeration, tkFloat, + tkString, tkSet, tkClass, {tkMethod, }{tkWChar, }tkLString, {tkLWString,} + tkVariant]; + var + I, Count: Integer; + PropInfo: PPropInfo; + TempList: PPropList; + begin + Count := GetPropList(FObject.ClassInfo, TypeKinds, nil); + if Count > 0 then + begin + v := VarArrayCreate([0, Count - 1, 0, 1], varVariant); + GetMem(TempList, Count * SizeOf(Pointer)); + try + GetPropList(FObject.ClassInfo, TypeKinds, TempList); + for I := 0 to Count - 1 do + begin + PropInfo := TempList^[I]; + v[i,1] := PropInfo^.PropType^.Kind; + case PropInfo^.PropType^.Kind of + tkClass: + v[i,0] := PropInfo^.Name; + tkString, + tkLString: + v[i,0] := PropInfo^.Name; + tkChar: + v[i,0] := PropInfo^.Name; + tkInteger: + v[i,0] := PropInfo^.Name; + tkFloat: + v[i,0] := PropInfo^.Name; + tkEnumeration: + v[i,0] := PropInfo^.Name; + tkSet: + v[i,0] := PropInfo^.Name; + tkVariant: + v[i,0] := PropInfo^.Name; + //None of these area implemented... + // tkWChar: + // tkLWString: + // tkUnknown: + // tkMethod: + end; + end; + finally + FreeMem(TempList, Count * SizeOf(Pointer)); + end; + end; + end; + + + { TIComponentDispatch } + + function TIComponentDispatch.GetComponents(Index: Integer): Variant; + begin + if (Index >= 0) and (Index < TComponent(FObject).ComponentCount) then + TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, TComponent(FObject).Components[Index]) + else + ; + // OleError(DISP_E_BADINDEX); + end; + + function TIComponentDispatch.GetComponentCount: Integer; + begin + Result := TComponent(FObject).ComponentCount; + end; + + function TIComponentDispatch.GetComponentIndex: Integer; + begin + Result := TComponent(FObject).ComponentIndex; + end; + + function TIComponentDispatch.GetOwner: Variant; + begin + TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, TComponent(FObject).Owner) + end; + + function TIComponentDispatch.GetDesignInfo: LongInt; + begin + Result := TComponent(FObject).DesignInfo; + end; + + function TIComponentDispatch.FindComponent(AName: String): Variant; + var + Obj: TComponent; + begin + Obj := TComponent(FObject).FindComponent(AName); + if Obj <> nil then + TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, Obj) + else + ; + // OleError(DISP_E_UNKNOWNNAME); + end; + + { TICollectionDispatch } + + function TICollectionDispatch.GetItemCount: Integer; + begin + Result := TCollection(FObject).Count; + end; + + procedure TICollectionDispatch.GetPropNames(var v: Variant); + var + Count, I : Integer; + vTemp : Variant; + begin + inherited GetPropNames(vTemp); + Count := -1; + if VarIsArray(vTemp) then + Count := VarArrayHighBound(vTemp, 1); + v := VarArrayCreate([0, Count + 2, 0, 1], varVariant); + for I := 0 to Count do + begin + v[I, 0] := vTemp[I, 0]; + v[I, 1] := vTemp[1, 1]; + end; + v[Count + 1, 0] := 'Count'; + v[Count + 1, 1] := tkInteger; + v[Count + 2, 0] := 'Items'; + v[Count + 2, 1] := tkClass; + VarClear(vTemp); + end; + + function TICollectionDispatch.GetProperty(PropName: String): Variant; + var + Count: Integer; + I: Integer; + Item: Variant; + Holder: Variant; + begin + if Propname = 'Count' then + begin + Holder := TCollection(FObject).Count; + Result := Holder; + end + else if Propname = 'Items' then + begin + Count := TCollection(FObject).Count; + Holder := VarArrayCreate([0, Count-1], varDispatch); + for I := 0 to Count-1 do + begin + TPublishedAutoDispatch(AutoDispatch).NewDispatch(Item, TCollection(FObject).Items[I]); + Holder[I] := Item; + end; + Result := Holder; + end + else + Result := inherited GetProperty(PropName); + end; + + { TIDataSetDispatch } + // SJP. 07/08/96 Returns FieldCount for TDataSet Objects. + function TIDataSetDispatch.GetFieldCount: Integer; + begin + Result := TDataSet(FObject).FieldCount; + end; + + // SJP. 07/08/96 Returns Tab-delimited/New-line separated + // 'data' for TDataSet Objects. + function TIDataSetDispatch.GetData: String; + var + I: Integer; + Data: String; + InitialBookMark: TBookMark; + begin + InitialBookMark := TDataSet(FObject).GetBookMark; + Data := ''; + TDataSet(FObject).First; + while TDataSet(FObject).EOF = False do + begin + for I := 0 to TDataSet(FObject).FieldCount - 1 do + begin + if TDataSet(FObject).Fields[I].InheritsFrom(TMemoField) then + Data := Data + '(Memo)' + else if TDataSet(FObject).Fields[I].InheritsFrom(TGraphicField) then + Data := Data + '(Graphic)' + else if TDataSet(FObject).Fields[I].InheritsFrom(TBlobField) then + Data := Data + '(Blob)' + else if TDataSet(FObject).Fields[I].InheritsFrom(TBytesField) then + Data := Data + '(Bytes)' + else if TDataSet(FObject).Fields[I].InheritsFrom(TVarBytesField) then + Data := Data + '(Var Bytes)' + else + Data := Data + TDataSet(FObject).Fields[I].AsString; + if I < TDataSet(FObject).FieldCount - 1 then + Data := Data + #9; + end; + TDataSet(FObject).Next; + Data := Data + #13; + end; + TDataSet(FObject).GotoBookMark(InitialBookMark); + TDataSet(FObject).FreeBookMark(InitialBookMark); + Result := Data; + end; + + { TIStringDispatch } + + procedure TIStringsDispatch.GetPropNames(var v: Variant); + var + Count, I : Integer; + vTemp : Variant; + begin + inherited GetPropNames(vTemp); + Count := -1; + if VarIsArray(vTemp) then + Count := VarArrayHighBound(vTemp, 1); + v := VarArrayCreate([0, Count + 2, 0, 1], varVariant); + for I := 0 to Count do + begin + v[I, 0] := vTemp[I, 0]; + v[I, 1] := vTemp[1, 1]; + end; + v[Count + 1, 0] := 'Text'; + v[Count + 1, 1] := tkString; + v[Count + 2, 0] := 'Strings'; + v[Count + 2, 1] := tkString; + VarClear(vTemp); + end; + + function TIStringsDispatch.GetProperty(PropName: String): Variant; + var + I: Integer; + Count: Integer; + Holder: Variant; + begin + if Propname = 'Strings' then + begin + Count := TStrings(FObject).Count; + if Count > 0 then + begin + Holder := VarArrayCreate([0, Count-1], varOleStr); + for I := 0 to Count-1 do + begin + // Arbitrary Max len of 32000 + Holder[I] := Copy(TStrings(FObject).Strings[I], 0, MaxStringItem); + end; + end; + Result := Holder; + end + else if Propname = 'Text' then + begin + Holder := TStrings(FObject).Text; + Result := Holder; + end + else + Result := inherited GetProperty(PropName); + end; + + { TIOleControlDispatch } + + function TIOleControlDispatch.GetOleObject: Variant; + begin + Result := TOleControl(FObject).OleObject; + end; + + { TIStringGridDispatch } + + procedure TIStringGridDispatch.GetPropNames(var v: Variant); + var + Count, I : Integer; + vTemp : Variant; + begin + inherited GetPropNames(vTemp); + Count := -1; + if VarIsArray(vTemp) then + Count := VarArrayHighBound(vTemp, 1); + v := VarArrayCreate([0, Count + 2, 0, 1], varVariant); + for I := 0 to Count do + begin + v[I, 0] := vTemp[I, 0]; + v[I, 1] := vTemp[1, 1]; + end; + v[Count + 1, 0] := 'Cols'; + v[Count + 1, 1] := tkClass; + v[Count + 2, 0] := 'Rows'; + v[Count + 2, 1] := tkClass; + VarClear(vTemp); + end; + + function TIStringGridDispatch.GetProperty(PropName: String): Variant; + var + Count: Integer; + I: Integer; + Item: Variant; + Holder: Variant; + begin + if Propname = 'Cols' then + begin + Count := TStringGrid(FObject).ColCount; + Holder := VarArrayCreate([0, Count-1], varDispatch); + for I := 0 to Count-1 do + begin + TPublishedAutoDispatch(AutoDispatch).NewDispatch(Item, TStringGrid(FObject).Cols[I]); + Holder[I] := Item; + end; + Result := Holder; + end + else if Propname = 'Rows' then + begin + Count := TStringGrid(FObject).RowCount; + Holder := VarArrayCreate([0, Count-1], varDispatch); + for I := 0 to Count-1 do + begin + TPublishedAutoDispatch(AutoDispatch).NewDispatch(Item, TStringGrid(FObject).Rows[I]); + Holder[I] := Item; + end; + Result := Holder; + end + else + Result := inherited GetProperty(PropName); + end; + + function TIStringGridDispatch.GetData: String; + var + row, col, RowCount, ColCount: Integer; + DataTemp, Data: String; + begin + //OutputDebugString( PChar( 'TIStringGridDispatch.GetData : ' + #13#10 ) ); + Data := ''; + + RowCount := TStringGrid(FObject).RowCount; + ColCount := TStringGrid(FObject).ColCount; + + for row := 0 to RowCount - 1 do + begin + DataTemp := ''; + for col := 0 to ColCount - 1 do + begin + DataTemp := DataTemp + TStringGrid(FObject).Cells[ col, row ]; + if col < ColCount - 1 then + DataTemp := DataTemp + #9; + end; + + Data := Data + DataTemp + #13; + end; + + //OutputDebugString( PChar( 'TIStringGridDispatch.GetData Returing: ' + Data + #13#10 ) ); + Result := Data; + end; + + { TITreeViewDispatch } + + procedure TITreeViewDispatch.GetPropNames(var v: Variant); + begin + inherited GetPropNames(v); + end; + + function TITreeViewDispatch.GetProperty(PropName: String): Variant; + var + Count: Integer; + I: Integer; + Holder: Variant; + Nodes: TTreeNodes; + Node, NodeTemp: TTreeNode; + NodePath: string; + begin + //OutputDebugString( PChar( 'TITreeViewDispatch.GetProperty : ' + PropName + #13#10) ); + if Propname = 'Items' then + begin + Nodes := TTreeView(FObject).Items; + Count := Nodes.Count; + Holder := VarArrayCreate([0, Count-1], varOleStr); + for I := 0 to Count - 1 do + begin + Node := Nodes.Item[ I ]; + NodeTemp := Node.Parent; + NodePath := Node.Text; + + while( NodeTemp <> nil ) do + begin + NodePath := NodeTemp.Text + '->' + NodePath; + NodeTemp := NodeTemp.Parent; + end; + Holder[I] := Copy( NodePath, 0, MaxStringItem); + end; + Result := Holder; + end + else + Result := inherited GetProperty(PropName); + end; + + { TIControlDispatch } + + function TIControlDispatch.GetParent: Variant; + begin + TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, TControl(FObject).Parent) + end; + + {TIWinControlDispatch} + + function TIWinControlDispatch.GetControls(Index: Integer): Variant; + begin + if (Index >= 0) and (Index < TWinControl(FObject).ControlCount) then + TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, TWinControl(FObject).Controls[Index]) + else + ; + // OleError(DISP_E_BADINDEX); + end; + + function TIWinControlDispatch.GetHandle: Integer; + begin + Result := TWinControl(FObject).Handle; + end; + + function TIWinControlDispatch.GetControlCount: Integer; + begin + Result := TWinControl(FObject).ControlCount; + end; + + function TIWinControlDispatch.ControlAtPos(X, Y: Integer): Variant; + var + Pt: TPoint; + Control: TControl; + begin + Pt.y := Y; + Pt.x := X; + Control := TWinControl(FObject).ControlAtPos(Pt, True); + if Control <> nil then + TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, Control) + else + ; + // OleError(DISP_E_BADINDEX); + end; + + { TIApplicationDispatch } + + constructor TIApplicationDispatch.Create; + begin + FObject := Application; + inherited Create; + end; + + function TIApplicationDispatch.GetDispFromHandle(Handle: Integer): Variant; + var + Obj: TObject; + begin + Obj := FindControl(Handle); + if (Obj <> nil) then + TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, Obj) + else + ; + // OleError(DISP_E_PARAMNOTFOUND); + end; + + function TIApplicationDispatch.GetHandle: Integer; + begin + Result := TApplication(FObject).Handle; + end; + + function TIApplicationDispatch.GetExeName: String; + begin + Result := TApplication(FObject).ExeName; + end; + + function TIApplicationDispatch.GetMainForm: Variant; + begin + TPublishedAutoDispatch(AutoDispatch).NewDispatch(Result, TApplication(FObject).MainForm); + end; + + procedure RegisterAutomationServer; + const + AutoClassInfo: TAutoClassInfo = ( + AutoClass: TIApplicationDispatch; + ProgID: 'SQAServer.Application'; + ClassID: '{92E4FBC0-1169-11D0-B5AB-00A02484352C}'; + Description: 'SQA Test Automation Server'; + Instancing: acMultiInstance); + begin + Automation.RegisterClass(AutoClassInfo); + end; + + function GetPropertyName : string; + var + propName : string; + begin + Result := 'SQAApplicationObject'; + if ( System.IsLibrary ) then + begin + propName := Format( 'SQAApplicationObject_%x', [ HInstance ] ); + Result := propName; + end; + end; + + function GetApplicationHandle: THandle; + var + appHandle : THandle; + begin + + Result := Application.Handle; + if ( Result = 0 ) then + begin + appHandle := FindWindow( PChar( 'TApplication' ), nil ); + Result := appHandle; + end; + end; + + procedure BeautifyApplicationWindow; + var + appD : TIApplicationDispatch; + propName : string; + aut : TAutoDispatch; + V : ^Variant; + appHandle : THandle; + begin + propName := GetPropertyName( ); + appHandle := GetApplicationHandle( ); + //OutputDebugString( PChar( Format( 'DEEnabler: Application handle :<%x>' + #13#10, [ appHandle ] ) ) ); + + if ( GetProp( appHandle, PChar(propName) ) = 0 ) then + begin + + New( V ); + VarClear( V^ ); + appD := TIApplicationDispatch.Create( ); + aut := appD.AutoDispatch; + + TVarData(V^).VType := varDispatch; + TVarData(V^).VDispatch := aut; + //VarToInterface(V^).AddRef; + + //OutputDebugString( PChar( Format( 'DEEnabler: SetProp <%s> apphandle <%x> object <%x>' + #13#10, [ PChar(propName), appHandle, THandle( V ) ] ) ) ); + SetProp( appHandle, PChar(propName), THandle( V ) ); + end; + end; + + procedure RevertApplicationWindowChanges; + var + th : THandle; + V : PVariant; + propName : PChar; + appHandle : THandle; + begin + propName := 'SQAApplicationObject'; + + appHandle := GetApplicationHandle(); + th := Windows.GetProp( appHandle, propName ); + if ( th <> 0 ) then + begin + V := PVariant(th); + Dispose( V ); + //VarToInterface(V^).Release; + Windows.RemoveProp( appHandle, propName ); + end; + end; + + function TIApplicationDispatch.FindControl1(hWndToFind: HWnd): TWinControl; + var + lControlAtom: TAtom; + lControlAtomString: string; + lOwningProcess: Pointer; + lUnknownProcess: DWORD; + lRM_GetObjectInstance: DWORD; + begin + + Result := nil; + if (hWndToFind <> 0) then + begin + lControlAtomString := Format('ControlOfs%.8X%.8X', [GetWindowLong( hWndToFind, GWL_HINSTANCE), GetCurrentThreadID]); + lControlAtom := GlobalAddAtom(PChar(lControlAtomString)); + + if GlobalFindAtom(PChar(lControlAtomString)) = lControlAtom then + begin + Result := Pointer(GetProp(hWndToFind, MakeIntAtom(lControlAtom))) + end + else + begin + lRM_GetObjectInstance := RegisterWindowMessage(PChar(lControlAtomString)); + + lOwningProcess := nil; + GetWindowThreadProcessID(hWndToFind, lOwningProcess); + + lUnknownProcess := GetCurrentProcessID(); + if DWORD(lOwningProcess) = lUnknownProcess then + begin + Result := Pointer(SendMessage(hWndToFind, lRM_GetObjectInstance, 0, 0)) + end + else + begin + Result := nil; + end; + end; + end; + end; + + begin + RegisterAutomationEnabler(TObject, TIObjectDispatch); + RegisterAutomationEnabler(TComponent, TIComponentDispatch); + RegisterAutomationEnabler(TControl, TIControlDispatch); + RegisterAutomationEnabler(TWinControl, TIWinControlDispatch); + // SJP: Added 07/01/96. + RegisterAutomationEnabler(TCollection, TICollectionDispatch); + // SJP: Added 07/08/96. + RegisterAutomationEnabler(TDataSet, TIDataSetDispatch); + // SJP: Added 07/08/96. + RegisterAutomationEnabler(TStrings, TIStringsDispatch); + // SJP: Added 08/04/96. + RegisterAutomationEnabler(TOleControl, TIOleControlDispatch); + // SJP: Added 03/12/97. + RegisterAutomationEnabler(TStringGrid, TIStringGridDispatch); + // TreeView support + RegisterAutomationEnabler(TTreeView, TITreeViewDispatch); + + //RegisterAutomationServer; + BeautifyApplicationWindow( ); + end. + Index: cprs/trunk/CPRS-Lib/uAccessAPI.pas =================================================================== --- cprs/trunk/CPRS-Lib/uAccessAPI.pas (revision 456) +++ (revision ) @@ -1,165 +1,0 @@ -unit uAccessAPI; - - -interface - -uses - Accessibility_TLB, - Controls, - ComCtrls, - Windows; - -function GetDefaultObject( Control: TWinControl): IAccessible; overload; -function GetDefaultObject( Control: TTreeNode): IAccessible; overload; -function GetLResult( wParam: integer; MyInterface: IAccessible): integer; - -const - ROLE_SYSTEM_TITLEBAR = $1; - ROLE_SYSTEM_MENUBAR = $2; - ROLE_SYSTEM_SCROLLBAR = $3; - ROLE_SYSTEM_GRIP = $4; - ROLE_SYSTEM_SOUND = $5; - ROLE_SYSTEM_CURSOR = $6; - ROLE_SYSTEM_CARET = $7; - ROLE_SYSTEM_ALERT = $8; - ROLE_SYSTEM_WINDOW = $9; - ROLE_SYSTEM_CLIENT = $a; - ROLE_SYSTEM_MENUPOPUP = $b; - ROLE_SYSTEM_MENUITEM = $c; - ROLE_SYSTEM_TOOLTIP = $d; - ROLE_SYSTEM_APPLICATION = $e; - ROLE_SYSTEM_DOCUMENT = $f; - ROLE_SYSTEM_PANE = $10; - ROLE_SYSTEM_CHART = $11; - ROLE_SYSTEM_DIALOG = $12; - ROLE_SYSTEM_BORDER = $13; - ROLE_SYSTEM_GROUPING = $14; - ROLE_SYSTEM_SEPARATOR = $15; - ROLE_SYSTEM_TOOLBAR = $16; - ROLE_SYSTEM_STATUSBAR = $17; - ROLE_SYSTEM_TABLE = $18; - ROLE_SYSTEM_COLUMNHEADER = $19; - ROLE_SYSTEM_ROWHEADER = $1a; - ROLE_SYSTEM_COLUMN = $1b; - ROLE_SYSTEM_ROW = $1c; - ROLE_SYSTEM_CELL = $1d; - ROLE_SYSTEM_LINK = $1e; - ROLE_SYSTEM_HELPBALLOON = $1f; - ROLE_SYSTEM_CHARACTER = $20; - ROLE_SYSTEM_LIST = $21; - ROLE_SYSTEM_LISTITEM = $22; - ROLE_SYSTEM_OUTLINE = $23; - ROLE_SYSTEM_OUTLINEITEM = $24; - ROLE_SYSTEM_PAGETAB = $25; - ROLE_SYSTEM_PROPERTYPAGE = $26; - ROLE_SYSTEM_INDICATOR = $27; - ROLE_SYSTEM_GRAPHIC = $28; - ROLE_SYSTEM_STATICTEXT = $29; - ROLE_SYSTEM_TEXT = $2a; - ROLE_SYSTEM_PUSHBUTTON = $2b; - ROLE_SYSTEM_CHECKBUTTON = $2c; - ROLE_SYSTEM_RADIOBUTTON = $2d; - ROLE_SYSTEM_COMBOBOX = $2e; - ROLE_SYSTEM_DROPLIST = $2f; - ROLE_SYSTEM_PROGRESSBAR = $30; - ROLE_SYSTEM_DIAL = $31; - ROLE_SYSTEM_HOTKEYFIELD = $32; - ROLE_SYSTEM_SLIDER = $33; - ROLE_SYSTEM_SPINBUTTON = $34; - ROLE_SYSTEM_DIAGRAM = $35; - ROLE_SYSTEM_ANIMATION = $36; - ROLE_SYSTEM_EQUATION = $37; - ROLE_SYSTEM_BUTTONDROPDOWN = $38; - ROLE_SYSTEM_BUTTONMENU = $39; - ROLE_SYSTEM_BUTTONDROPDOWNGRID = $3a; - ROLE_SYSTEM_WHITESPACE = $3b; - ROLE_SYSTEM_PAGETABLIST = $3c; - ROLE_SYSTEM_CLOCK = $3d; - - - NAVDIR_MIN = 0; - NAVDIR_UP = 1; - NAVDIR_DOWN = 2; - NAVDIR_LEFT = 3; - NAVDIR_RIGHT = 4; - NAVDIR_NEXT = 5; - NAVDIR_PREVIOUS = 6; - NAVDIR_FIRSTCHILD = 7; - NAVDIR_LASTCHILD = 8; - NAVDIR_MAX = 9; - -implementation - -uses - Classes; - -type - TCreateStdAccessibleObject = function(hwnd: HWND; idObject: DWORD; const riid: TGUID; var Accessible: IAccessible): integer; stdcall; - TLresultFromObject = function( const riid: TGUID; wParam: integer; Accessible: Pointer): integer; stdcall; - - PhysicalInterfaceReference = record - P1: pointer; - P2: pointer; - end; - - PPhysicalInterfaceReference = ^PhysicalInterfaceReference; - -var - CreateStdAccessibleObject: TCreateStdAccessibleObject; - LresultFromObject: TLresultFromObject; -var - - OleAccHandle: THandle; - -function GetDefaultObject( Control: TWinControl): IAccessible; -begin - if Assigned(CreateStdAccessibleObject) then - begin - if CreateStdAccessibleObject(Control.Handle, OBJID_CLIENT, IID_IAccessible, Result) <> S_OK then - result := nil; - end - else - result := nil; -end; - -function GetDefaultObject( Control: TTreeNode): IAccessible; -begin - if Assigned(CreateStdAccessibleObject) then - begin - if CreateStdAccessibleObject(Control.Handle, OBJID_CLIENT, IID_IAccessible, Result) <> S_OK then - result := nil; - end - else - result := nil; -end; - -function GetLResult( wParam: integer; MyInterface: IAccessible): integer; -begin - if Assigned(LresultFromObject) then - begin - result := LresultFromObject(IID_IAccessible, wParam, PPhysicalInterfaceReference(@MyInterface)^.P1); // Increments ref count - end - else - result := E_NOINTERFACE; -end; - - -initialization - OleAccHandle := LoadLibrary('OLEACC.DLL'); - if OleAccHandle <> 0 then - begin - @CreateStdAccessibleObject := GetProcAddress(OleAccHandle, 'CreateStdAccessibleObject'); - @LresultFromObject := GetProcAddress(OleAccHandle, 'LresultFromObject'); - end - else - begin - @CreateStdAccessibleObject := nil; - @LresultFromObject := nil; - end; - -finalization - if OleAccHandle <> 0 then - FreeLibrary(OleAccHandle); - -end. -