Changeset 1679 for cprs/trunk/CPRS-Lib/ORFn.pas

Timestamp:

May 7, 2015, 12:34:29 PM (9 years ago)

Author:

healthsevak

Message:

Updating the working copy to CPRS version 28

File:

• cprs/trunk/CPRS-Lib/ORFn.pas (modified) (8 diffs)

cprs/trunk/CPRS-Lib/ORFn.pas

@@ -36 +36 @@
 function LowerOf(i, j: Integer): Integer;
 function StrToFloatDef(const S: string; ADefault: Extended): Extended;
+function RectContains(Rect: TRect; Point: TPoint): boolean;
 
 { String functions }
@@ -41 +42 @@
 function ContainsAlpha(const x: string): Boolean;
 function ContainsVisibleChar(const x: string): Boolean;
+function ContainsUpCarretChar(const x: string): Boolean;
 function ConvertSpecialStrings(const x: string): String;
 function CRCForFile(AFileName: string): DWORD;
@@ -118 +120 @@
 
 { Misc functions }
+function CPRSInstances: integer;
 { You MUST pass an address to an object variable to get KillObj to work }
 procedure KillObj(ptr: Pointer; KillObjects: boolean = FALSE);
@@ -124 +127 @@
 procedure CallWhenIdle(CallProc: TORIdleCallProc; Msg: String);
 procedure CallWhenIdleNotifyWhenDone(CallProc, DoneProc: TORIdleCallProc; Msg: String);
+
 procedure menuHideAllBut(aMenuItem: tMenuItem; butItems: array of tMenuItem);
 function TabIsPressed : Boolean;
 function ShiftTabIsPressed : Boolean;
 function EnterIsPressed : Boolean;
+procedure ScrollControl(Window: TScrollingWinControl; ScrollingUp: boolean; Amount: integer = 40);
 
 implementation  // ---------------------------------------------------------------------------
@@ -387 +392 @@
 end;
 
+function RectContains(Rect: TRect; Point: TPoint): boolean;
+begin
+  Result := ((Point.X >= Rect.Left) and 
+             (Point.X <= Rect.Right) and
+             (Point.Y >= Rect.Top) and
+             (Point.Y <= Rect.Bottom));
+end;
+
 { String functions }
 
@@ -415 +428 @@
   Result := False;
   for i := 1 to Length(x) do if x[i] in ['!'..'~'] then  // ordinal values 33..126
+  begin
+    Result := True;
+    break;
+  end;
+end;   
+
+function ContainsUpCarretChar(const x: string): Boolean;
+{ returns true if the string contains the ^ character }
+var
+  i: Integer;
+begin
+  Result := False;
+  for i := 1 to Length(x) do if x[i] = '^' then  // ordinal values 33..126
   begin
     Result := True;
@@ -2022 +2048 @@
 *)
 
+function CPRSInstances: integer;
+// returns the number of CPRS sessions open
+var
+  AHandle: hWnd;
+  LengthText, LengthConst, counter: Integer;
+  CharText: array [0..254] of Char;
+  TitleText, TitleCompare: string;
+const
+  TX_IN_USE = 'VistA CPRS in use by: '; // use same as in fFrame
+begin
+  counter := 0;
+  LengthConst := length(TX_IN_USE);
+  AHandle := FindWindow(nil, nil);
+  while AHandle <> 0 do begin
+    LengthText := GetWindowText(AHandle, CharText, 255);
+    if LengthText > 0 then
+    begin
+      TitleText := CharText;
+      TitleCompare := copy(TitleText, 1, LengthConst);
+      if TitleCompare = TX_IN_USE then
+        counter := counter + 1;
+    end;
+    AHandle := GetWindow(AHandle, GW_HWNDNEXT);
+  end;
+  Result := counter;
+end;
+
 { You MUST pass an address to an object variable to get KillObj to work }
 procedure KillObj(ptr: Pointer; KillObjects: boolean = FALSE);
@@ -2197 +2250 @@
 end;
 
+procedure ScrollControl(Window: TScrollingWinControl; ScrollingUp: boolean; Amount: integer = 40);
+var
+  Delta: integer;
+
+  // This is needed to tell the child components that they are moving,
+  // The TORCombo box, for example, needs to close a dropped down window when it moves.
+  // If Delphi had used standard scroll bars, instead of the customized flat ones, this
+  // code wouldn't be needed
+  procedure SendMoveMessage(Ctrl: TWinControl);
+  var
+    i: integer;
+  begin
+    for i := 0 to Ctrl.ControlCount - 1 do
+    begin
+      if Ctrl.Controls[i] is TWinControl then with TWinControl(Ctrl.Controls[i]) do
+      begin
+        SendMessage(Handle, WM_MOVE, 0, (Top * 65536) + Left);
+        SendMoveMessage(TWinControl(Ctrl.Controls[i]));
+      end;
+    end;
+  end;
+  
+begin
+  Delta := Amount;
+  if ScrollingUp then
+  begin
+    if Window.VertScrollBar.Position < Delta then
+      Delta := Window.VertScrollBar.Position;
+    Delta := - Delta;
+  end
+  else
+  begin
+    if (Window.VertScrollBar.Range - Window.VertScrollBar.Position) < Delta then
+      Delta := Window.VertScrollBar.Range - Window.VertScrollBar.Position;
+  end;
+  if Delta <> 0 then
+  begin
+    Window.VertScrollBar.Position := Window.VertScrollBar.Position + Delta;
+    SendMoveMessage(Window);
+  end;
+end;
+
 initialization
   FBaseFont := TFont.Create;