I have the following code, all the code needs to do is go through a list of vehicles and remove the spaces in each registration but before changing it, it should check to make sure the ammended registration doesn't exist. The following code is what I am using:
unit Main;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, Menus, cxLookAndFeelPainters, StdCtrls, cxButtons, Gauges, DB,
DBTables, StrUtils;
type
TfrmMain = class(TForm)
prgTotal: TGauge;
btnStart: TcxButton;
tblVeh: TTable;
tblVehRegNo: TStringField;
procedure btnStartClick(Sender: TObject);
private
procedure OpenTable(pTable: TTable);
procedure CloseTable(pTable: TTable; pPost: Boolean);
{ Private declarations }
public
{ Public declarations }
end;
var
frmMain : TfrmMain;
lvRegLst : TStringList;
lvTblSize : Integer;
lvOrigReg : String;
lvNewReg : String;
lvTest : integer;
implementation
{$R *.dfm}
procedure TfrmMain.btnStartClick(Sender: TObject);
begin
btnStart.Enabled := False;
lvRegLst := TStringList.Create;
// Open Tables
tblVeh.Open;
tblVeh.First;
// Set progress
prgTotal.MinValue := 0;
lvTblSize := tblVeh.RecordCount;
prgTotal.MaxValue := tblVeh.RecordCount;
btnStart.Caption := 'Parsing Registration Numbers...';
// Conversion
while not tblVeh.Eof do
begin
lvRegLst.Add(tblVehRegNo.AsString);
tblVeh.Next;
prgTotal.AddProgress(1);
Application.ProcessMessages;
end;
tblVeh.First;
lvTest := lvRegLst.Count;
prgTotal.Progress := 0;
btnStart.Caption := 'Removing Spaces...';
while not tblVeh.Eof do
begin
lvOrigReg := tblVehRegNo.AsString;
lvNewReg := AnsiReplaceStr(lvOrigReg,' ','');
if lvRegLst.IndexOf(lvNewReg) = -1 then
begin
tblVeh.Edit;
tblVehRegNo.AsString := lvNewReg;
prgTotal.AddProgress(1);
tblVeh.Post;
end;
tblVeh.Next;
prgtotal.AddProgress(1);
Application.ProcessMessages;
end;
// Close Tables
tblVeh.Edit;
tblVeh.Post;
tblVeh.Close;
btnStart.Caption := '&Start Conversion';
btnStart.Enabled := True;
end;
I have stepped through the code and all looks fine and it successfuly changes the registration against the vehicle but when looking at the table afterwards it's not made any changes.
The issue was with the database itself, it turns out 'RegNo' is the only key field so it's the default index. As my conversion was running through it was changing registrations which moved the 'cursor' and skipped over a number of registrations.
I have added another index for the purpose of this conversion but making around 50-60 passes over their data would have eventually sorted out all of the registrations.
Thank you for all of the help.
Related
I аm trying to get the enumeration name value using RTTI.
My objective is to get the corresponding enumerate name value in Enum1(Tsex) from the selected enumerate name value in Enum2(iterator) using a string value.
Here is the code that I have implemented. I am using Delphi 7.
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,Dialogs,typinfo;
type
Tsex = (homme,femme);
iterator = (H,F);
TForm1 = class(TForm)
procedure FormShow(Sender: TObject);
private
{ Déclarations privées }
public
{ Déclarations publiques }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormShow(Sender: TObject);
var
i : integer;
OT: Tsex;
FT: iterator;
begin
i:=0;
OT := Low(Tsex);
for FT := Low(iterator) to High(iterator) do
if GetEnumName(TypeInfo(iterator), Ord(FT)) = 'F' then
begin
showmessage(GetEnumName(TypeInfo(Tsex), Ord(OT)));
end;
i:=i+1;
OT:=Succ(OT);
end;
When I use H as a string I get homme, but when I use F I also get homme. But it needs to be femme.
Problem:
The problem in your code is that you are missing a begin after for, and this causes increment of i and assignment of OT to happen after the iteration is complete.
What you need to change is:
var
i : integer;
OT: Tsex;
FT: iterator;
begin
i:=0;
OT := Low(Tsex);
for FT := Low(iterator) to High(iterator) do
begin // <- Add begin here
if GetEnumName(TypeInfo(iterator), Ord(FT)) = 'F' then
begin
showmessage(GetEnumName(TypeInfo(Tsex), Ord(OT)));
end;
i:=i+1;
OT:=Succ(OT);
end;
end; // <- Add end; here
Alternative solutions:
As David has pointed out, it is better to use an array to map another set of values to your enum. Like this:
type
TSex = (homme, femme);
const
SexDBValues: array [TSex] of string =
('H', 'F');
type
TForm1 = class(TForm)
procedure FormShow(Sender: TObject);
private
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function GetMyEnumValue(const aDBValue: string): TSex;
var
value: TSex;
begin
for value := Low(TSex) to High(TSex) do
begin
if SameText(SexDBValues[value], aDBValue) then
begin
Result := value;
Exit;
end;
end;
end;
procedure TForm1.FormShow(Sender: TObject);
var
value: TSex;
begin
value := GetMyEnumValue('H');
ShowMessage(GetEnumName(TypeInfo(TSex), Ord(value)));
end;
And when your enum type contains only two values, and is unlikely to have additional values in future, you can just use good old if-else operator:
function GetMyEnumValue(const aDBValue: string): TSex;
begin
if SameText(aDBValue, 'F') then
begin
Result := femme;
end else
begin
Result := homme;
end;
end;
In few words, avoid overengineering problems.
Note: We are using string to store the character value and SameText to compare it, as it compares text case-insensitively. Plus, it allows you to compare text of multiple characters, if in future you change your mind on how values are stored in DB.
Advice:
I would also recommend you to consult with Delphi Coding Style Guide.
It might seem unrelated to problem, but following good practice on indentation helps to avoid such problems.
Guidelines on naming types and variables are also important. They will similarly save you in other situations.
I am trying to write a separate unit for my main form to call, all of my other units are working except for one that uses TTimer.
Basically what the function is supposed to be doing is that the main form uDataReceived calls BlinkRect(Gateway) which is processed in rRectControl unit and the according Rectangle will blink in the main form.
Here are the codes:
unit uRectControl;
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes,
System.Variants, System.IOUtils, FMX.Graphics, FMX.Types, FMX.Objects;
var
Blinks: array [0 .. 2] of record Rectangle: TRectangle;
Timer: TTimer;
end;
type
TMyClass = Class(TObject)
private
Timer1: TTimer;
procedure Timer1Timer(Sender: TObject);
public
procedure BlinkRect(Gateway: integer);
end;
procedure AssignRectangles;
implementation
uses uDataReceived;
// Error shows "Cannot resolve unit name 'uDataReceived'
{ TMyClass }
procedure AssignRectangles;
var
i: integer;
begin
Blinks[0].Rectangle := TC_Theft_Detection.rect1;
// Error shows Undeclared Identifier TC_Theft_Detection (which is the name of the main form)
Blinks[0].Timer := nil;
Blinks[1].Rectangle := TC_Theft_Detection.rect2;
Blinks[1].Timer := nil;
Blinks[2].Rectangle := TC_Theft_Detection.rect3;
Blinks[2].Timer := nil;
for i := 0 to 2 do
Blinks[i].Rectangle.Fill.Color := TAlphacolors.blue;
end;
procedure TMyClass.BlinkRect(Gateway: integer);
begin
Blinks[Gateway].Rectangle.Fill.Color := TAlphacolors.Red;
Blinks[Gateway].Rectangle.Fill.Kind := TBrushKind.Solid;
Blinks[Gateway].Rectangle.Stroke.Thickness := 0.3;
Blinks[Gateway].Rectangle.Stroke.Color := TAlphacolors.Black;
if Blinks[Gateway].Timer = nil then
begin
Blinks[Gateway].Timer := TTimer.Create(nil);
Blinks[Gateway].Timer.OnTimer := Timer1Timer;
Blinks[Gateway].Timer.Interval := 500;
Blinks[Gateway].Timer.Tag := Gateway;
Blinks[Gateway].Timer.Enabled := True;
end;
end;
procedure TMyClass.Timer1Timer(Sender: TObject);
var
Timer: TTimer;
begin
Timer := TTimer(Sender);
Blinks[Timer.Tag].Rectangle.Visible := not Blinks[Timer.Tag]
.Rectangle.Visible;
end;
end.
I know there must be something wrong with the unit shown above, and my question is:
How to work with TTimer in a separate unit and how to call the procedure BlinkRect(Gateway) on the main form.
Thanks a lot!!
Your code in uRectControl works provided AssignRectangles is called before you attempt to call BlinkRect. However there are a number of issues to be addressed.
1) Cross dependency of units
The form (uDataReceived) apparently uses uRectControl and that is fine. The way uRectControl is written it needs to use (uses uDataReceived in the implementation) the form and this is not good.
This error is simple to correct, because the AssignRectangles procedure is the only place where the form is referred to. AssignRectangles could just as well be in the form, since the Blinks[] array is global (in the interface of uRectControl) and can therefore be accessed by the form.
2) Global variables
Global variables should be avoided as much as possible. You have defined both the Blinks[] array and the Timer to be global, so you might by mistake access and modify them from anywhere in your program just by adding uRectControl to a uses clause. In future development you might add new forms that have indicators you want to blink and add TRectangles to the Blinks[] array possibly overwriting value that are already there and you end up in a mess. I will address this issue in my suggestion below.
3) Hardcoded entities
In Proof Of Concept code it is acceptable (or not) to hardcode constants, sizes of arrays etc. but not in production code. Just think about all changes you need to do just to add one more blinking rectangle to the form. Dynamical arrays or better TList and its derivatives etc. comes to rescue here. You have also limited yourself to only TRectangles. What if you would like to have circular indicators in your form?
4) Unsyncronized blinking
It may look cool (not really) when indicators are blinking all over the place, but actually it is just distracting. I guess you tried to change this with the timer in TMyClass, but you still left the individual timers in the Blinks records. I will address this also in my suggestion below.
Here is a suggestion
unit ShapeBlinker;
interface
uses
System.SysUtils, System.UITypes, System.Classes, System.Generics.Collections,
FMX.Graphics, FMX.Types, FMX.Objects;
type
TBlinkState = (bsOff, bsBlinking, bsSteady);
I have a background in Fire Alarm Systems, and it is common to have three states; off, blinking and steady lit. TBlinkState represents these.
Then comes a class that represent indicators in the UI. An indicator can be any TShape derivative like TRectangle, TCircle, TPath etc. Each state can have its own color.
type
[...]
TBlinkingShape = class
private
FShape: TShape;
FState: TBlinkState;
FOffColor: TAlphaColor;
FBlinkColor: TAlphaColor;
FSteadyColor: TAlphaColor;
public
constructor Create(AShape: TShape);
procedure SetBlinkState(NewState: TBlinkState);
end;
The field FShape holds a reference to a TShape derivative. Through this reference we have access to the actual component on the UI form and can change its color. We will see later how the TShape is passed to the constructor.
Then the second class which manages a collection of TBlinkingShape, timing and actual color changes of the indicators on the form.
type
[...]
TShapeBlinker = class
private
FBlinkingShapes: TObjectList<TBlinkingShape>;
FBlinkPhase: integer;
FTimer: TTimer;
public
constructor Create;
destructor Destroy; override;
procedure RegisterShape(Shape: TShape; OffColor, BlinkColor, SteadyColor: TAlphaColor);
procedure UnRegisterShape(Shape: TShape);
procedure BlinkTimer(Sender: TObject);
procedure SetBlinkState(Shape: TShape; NewState: TBlinkState);
function GetBlinkState(Shape: TShape): TBlinkState;
end;
FBlinkingShapes is the object list that holds instances of TBlinkingShapes.
FBlinkPhase syncronizes blinking of the indicators so that all blinking indicators change to the BlinkColor simultaneously. FTimer is common for all indicators.
Procedure RegisterShape is called by the UI when it wants to add an indicator to the list. UnRegister is called when an indicator is to be removed from the list. SetBlinkState is used to change state and GetBlinkState to retrieve the state of an indicator.
The unit is designed to be usable by any number of forms, synchronizing blinking for all of them. This requires that the TShapeBlinker is a singleton. It is therefore created in the initialization section of the unit, and freed in the finalization.
The instance is held by a var in the implementation, thus inaccessible directly from any other unit. Access is provided by a function declared as the last item in the interface of the unit:
function ShapeBlinker: TShapeBlinker;
This effectively prevents a mistake to accidentally call ShapeBlinker.Create.
Instead of commenting on each method I just copy the implementation here:
implementation
var
SShapeBlinker: TShapeBlinker;
function ShapeBlinker: TShapeBlinker;
begin
result := SShapeBlinker;
end;
{ TBlinkingShape }
constructor TBlinkingShape.Create(AShape: TShape);
begin
FShape := AShape;
FState := bsOff;
end;
procedure TBlinkingShape.SetBlinkState(NewState: TBlinkState);
begin
FState := NewState;
case NewState of
bsOff: begin
FShape.Fill.Color := FOffColor;
end;
bsBlinking: begin
FShape.Fill.Color := FBlinkColor;
end;
bsSteady: begin
FShape.Fill.Color := FSteadyColor;
end;
end;
end;
{ TShapeBlinker }
constructor TShapeBlinker.Create;
begin
FBlinkingShapes := TObjectList<TBlinkingShape>.Create;
FTimer := TTimer.Create(nil);
FTimer.OnTimer := BlinkTimer;
FTimer.Interval := 500;
FTimer.Enabled := False;
end;
destructor TShapeBlinker.Destroy;
begin
FTimer.Enabled := False;
FTimer.Free;
FBlinkingShapes.Free;
inherited;
end;
function TShapeBlinker.GetBlinkState(Shape: TShape): TBlinkState;
var
RegShape: TBlinkingShape;
begin
result := bsOff;
for RegShape in FBlinkingShapes do
if Shape = RegShape.FShape then result := RegShape.FState;
end;
procedure TShapeBlinker.SetBlinkState(Shape: TShape; NewState: TBlinkState);
var
RegShape: TBlinkingShape;
begin
for RegShape in FBlinkingShapes do
if Shape = RegShape.FShape then RegShape.SetBlinkState(NewState);
self.FTimer.Enabled := True;
end;
procedure TShapeBlinker.BlinkTimer(Sender: TObject);
var
i: integer;
begin
FTimer.Enabled := False;
FBlinkPhase := (FBlinkPhase + 1) mod 2;
for i := 0 to FBlinkingShapes.Count-1 do
with FBlinkingShapes[i] do
begin
case FState of
bsOff: begin
FShape.Fill.Color := FOffColor;
end;
bsBlinking: begin
if FBlinkPhase = 1 then
FShape.Fill.Color := FOffColor // alt. FSteadyColor
else
FShape.Fill.Color := FBlinkColor;
FTimer.Enabled := True;
end;
bsSteady: begin
FShape.Fill.Color := FSteadyColor;
end;
end;
end;
end;
procedure TShapeBlinker.RegisterShape(Shape: TShape; OffColor, BlinkColor, SteadyColor: TAlphaColor);
begin
with FBlinkingShapes[FBlinkingShapes.Add(TBlinkingShape.Create(Shape))] do
begin
FOffColor := OffColor; //TAlphaColors.Silver;
FBlinkColor := BlinkColor; //TAlphaColors.Red;
FSteadyColor := SteadyColor; //TAlphaColors.Yellow;
end;
end;
procedure TShapeBlinker.UnRegisterShape(Shape: TShape);
var
i: integer;
begin
for i := FBlinkingShapes.Count-1 downto 0 do
if FBlinkingShapes[i].FShape = Shape then
FBlinkingShapes.Delete(i);
end;
initialization
SShapeBlinker := TShapeBlinker.Create;
finalization
SShapeBlinker.Free;
end.
Finally a few words about usage. Consider a form, say TAlarmView, with 2 TRectangle and 1 TCircle.
In FormCreate you might register these for blinking as follows
procedure TAlarmView.FormCreate(Sender: TObject);
begin
ShapeBlinker.RegisterShape(Rect1, TAlphaColors.Silver, TAlphaColors.Red, TAlphaColors.Yellow);
ShapeBlinker.RegisterShape(Circle1, TAlphaColors.Silver, TAlphaColors.Red, TAlphaColors.Yellow);
ShapeBlinker.RegisterShape(Rect3, TAlphaColors.Silver, TAlphaColors.Red, TAlphaColors.Yellow);
end;
and then test them with button clicks like
procedure TAlarmView.Button1Click(Sender: TObject);
begin
case ShapeBlinker.GetBlinkState(Rect1) of
bsOff: ShapeBlinker.SetBlinkState(Rect1, bsBlinking);
bsBlinking: ShapeBlinker.SetBlinkState(Rect1, bsSteady);
else ShapeBlinker.SetBlinkState(Rect1, bsOff);
end;
end;
As you see I just go through the different states for each click.
Friends,
Need to screenshot of the all desktop WITHOUT MY FORM and load in TImage.
Success in Windows XP, 7 - with just ALPHABLEND = TRUE + SCREENSHOT PROCEDURE.
But same code does not work in Windows 8 - capture all screen INCLUDING THE FORM.
I know the problem is related to AERO - DWM.EXE - success using pssuspend.exe (sysinternals) - suspending winlogon.exe and killing dwm.exe
Someone could tell me how to capture all desktop without my form also in Windows 8?
prntscr.com/314rix - SUCESS IN WIN7
prntscr.com/314tj7 - FAILED IN WIN8
prntscr com/31502u - SUSPEND WINLOGON.EXE and KILL DWM.EXE IN WIN8
www sendspace com/file/b5oxhb - SOURCE CODE
// FORM -> ALPHABLEND -> TRUE
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls,
Clipbrd;
type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
ScrollBox1: TScrollBox;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure ScreenShot(DestBitmap: TBitmap);
var
DC: HDC;
begin
DC:=GetDC(GetDesktopWindow);
try
DestBitmap.Width:=GetDeviceCaps(DC, HORZRES);
DestBitmap.Height:=GetDeviceCaps(DC, VERTRES);
BitBlt(DestBitmap.Canvas.Handle,0,0,DestBitmap.Width,DestBitmap.Height,DC,0,0,SRCCOPY);
finally
ReleaseDC(GetDesktopWindow, DC);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ScreenShot(Image1.Picture.Bitmap);
end;
end.
If you want to take a screenshot without your window appearing: hide the window before taking the screenshot:
procedure TForm1.Button1Click(Sender: TObject);
var
desktop: TGraphic;
fDisable: BOOL;
begin
{
Capture a screenshot without this window showing
}
//Disable DWM transactions so the window hides immediately
if DwmApi.DwmCompositionEnabled then
begin
fDisable := True;
OleCheck(DwmSetWindowAttribute(Self.Handle, DWMWA_TRANSITIONS_FORCEDISABLED, #fDisable, sizeof(fDisable)));
end;
try
//Hide the window
Self.Hide;
try
//Capture the desktop
desktop := CaptureDesktop;
finally
//Re-show our window
Self.Show;
end;
finally
//Restore animation transitions
if DwmApi.DwmCompositionEnabled then
begin
fDisable := False;
DwmSetWindowAttribute(Self.Handle, DWMWA_TRANSITIONS_FORCEDISABLED, #fDisable, sizeof(fDisable));
end;
end;
//Save the screenshot somewhere
desktop.SaveToFile('d:\temp\ss.bmp');
end;
With the magic happening in:
function CaptureDesktop: TGraphic;
const
CAPTUREBLT = $40000000;
SM_XVIRTUALSCREEN = 76;
SM_YVIRTUALSCREEN = 77;
SM_CXVIRTUALSCREEN = 78;
SM_CYVIRTUALSCREEN = 79;
var
nDesktopWidth, nDesktopHeight: Integer;
tmpBmp: TBitmap;
hwndDesktop: HWND;
dcDesktop: HDC;
begin
Result := nil;
{
GetWindowRect(GetDesktopWindow)
is completely wrong. It will intentionally return only the rectangle of the primary monotor. See MSDN.
}
{ Cannot handle dpi virtualization
//Get the rect of the entire desktop; not just the primary monitor
ZeroMemory(#desktopRect, SizeOf(desktopRect));
for i := 0 to Screen.MonitorCount-1 do
begin
desktopRect.Top := Min(desktopRect.Top, Screen.Monitors[i].Top);
desktopRect.Bottom := Max(desktopRect.Bottom, Screen.Monitors[i].Top + Screen.Monitors[i].Height);
desktopRect.Left := Min(desktopRect.Left, Screen.Monitors[i].Left);
desktopRect.Right := Max(desktopRect.Right, Screen.Monitors[i].Left + Screen.Monitors[i].Width);
end;
//Get the size of the entire desktop
nDesktopWidth := (desktopRect.Right - desktopRect.Left);
nDesktopHeight := (desktopRect.Bottom - desktopRect.Top);
}
//Also doesn't handle dpi virtualization; but is shorter and unioning rects
nDesktopWidth := GetSystemMetrics(SM_CXVIRTUALSCREEN);
nDesktopHeight := GetSystemMetrics(SM_CYVIRTUALSCREEN);
tmpBmp:= TBitmap.Create;
try
tmpBmp.Width := nDesktopWidth;
tmpBmp.Height := nDesktopHeight;
//dcDesktop := GetDC(0); //
hwndDesktop := GetDesktopWindow;
dcDesktop := GetDC(hwndDesktop); //GetWindowDC(0) returns the DC of the primary monitor (not what we want)
if dcDesktop = 0 then
Exit;
try
if not BitBlt(tmpBmp.Canvas.Handle, 0, 0, nDesktopWidth, nDesktopHeight, dcDesktop, 0, 0, SRCCOPY or CAPTUREBLT) then
Exit;
finally
ReleaseDC(0, dcDesktop);
end;
except
tmpBmp.Free;
raise;
end;
// CaptureScreenShot(GetDesktopWindow, Image, false);
Result := tmpBmp;
end;
The screen with the app running:
And the saved screenshot:
Note: Any code released into public domain. No attribution required.
I have ID of the process. This process is an application which have a main window.
I am trying to close this application by sending WM_CLOSE to its main window.
I am searching its main window by using EnumWindows.
The problem is, that this application which I try to close, does not close always.
It is multithreaded application. Notepad and Calc are always closing when I use the same method which is presented below. But I am not sure if it is working properly cause it returns me many handles to the same window, even for Calc.exe.
Is it possible that thread is taking a handle to window and then this handle somehow become corrupted? Or maybe I should not use GetWindowThreadProcessId(hHwnd,pPid) but some other function in the callback?
I am out of ideas, would be grateful for any help. Thanks.
Code snippet:
unit Unit22;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm22 = class(TForm)
edtprocID: TEdit;
lblEnterProcessID: TLabel;
btnCloseProcessWindow: TButton;
lblStatus: TLabel;
procedure btnCloseProcessWindowClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type
THandleAndHWND = record
ProcID: THandle;
WindowHandle: HWND;
end;
var
Form22: TForm22;
var
HandleAndHWNDArray: array of THandleAndHWND;
HandeIndex, lp: Integer;
implementation
{$R *.dfm}
function EnumProcess(hHwnd: HWND; lParam : integer): boolean; stdcall;
var
pPid : DWORD;
begin
//if the returned value in null the
//callback has failed, so set to false and exit.
if (hHwnd=0) then
begin
result := false;
end else
begin
GetWindowThreadProcessId(hHwnd,pPid);
Inc(HandeIndex);
HandleAndHWNDArray[HandeIndex].ProcID := pPid;
HandleAndHWNDArray[HandeIndex].WindowHandle := hHwnd;
Result := true;
end;
end;
procedure TForm22.btnCloseProcessWindowClick(Sender: TObject);
var
ProcID: Cardinal;
i, LastError: Integer;
begin
HandeIndex := -1;
ProcID := StrToInt(edtprocID.Text);
SetLength(HandleAndHWNDArray, 3000);
EnumWindows(#EnumProcess,lp);
for i := 0 to HandeIndex do //After EnumWindows HandleIndex is above 500 despite the fact that I have like 10 openned windows max
begin //That means that EnumWindows was called 500 times?
if HandleAndHWNDArray[i].ProcID = ProcID then //search for process equal to procces ID given by the user
begin
//if we have a processID then we have a handle to its main window
if PostMessage(HandleAndHWNDArray[i].WindowHandle, WM_CLOSE, 0, 0) then
begin
lblStatus.Caption := 'message posted!';
end else
begin
LastError := GetLastError;
lblStatus.Caption := Format('Error: [%d] ' + SysErrorMessage(LastError), [LastError]);
end;
Exit;
end;
end;
end;
end.
Have a look in this Knowledge Base Article here on how to close another application as cleanly as possible. You are doing it right so far. The Article suggests that you
first post WM_CLOSE to all windows of the application (since you cannot know for sure which one is the main).
wait with a timeout and if the timeout elapses
kill the application using TerminateProcess
I agree.
The most recent Crystal XI component for Delphi was released for Delphi 7. That VCL component compiles in D2007, but gives me errors at runtime. What is the best way to display a database-connected Crystal Report in a Delphi 2007 application?
This is the solution I've found, using ActiveX:
First, register the Active X control like this:
In Delphi, choose Component -> Import Component
Click on "Type Library", click Next
Choose "Crystal ActiveX Report Viewer Library 11.5"
Pick whatever Palette Page you want (I went with "Data Access")
Choose an import location
Exit out of the wizard
Add the location you chose to your project Search Path
Now this code should work:
...
uses
CrystalActiveXReportViewerLib11_5_TLB, OleAuto;
...
procedure TForm1.Button1Click(Sender: TObject);
var
cry : TCrystalActiveXReportViewer;
oRpt, oApp : variant;
i : integer;
frm : TForm;
begin
cry := TCrystalActiveXReportViewer.Create(Self);
oApp := CreateOleObject('CrystalRuntime.Application');
oRpt := oApp.OpenReport('c:\my_report.rpt',1);
for i := 1 to oRpt.Database.Tables.Count do begin
oRpt.Database.Tables[i].ConnectionProperties.Item['User ID'] := 'username';
oRpt.Database.Tables[i].ConnectionProperties.Item['Password'] := 'password';
end;
frm := TForm.Create(Self);
try
cry.Parent := frm;
cry.Align := alClient;
cry.ReportSource := oRpt;
cry.ViewReport;
frm.Position := poOwnerFormCenter;
frm.ShowModal;
finally
FreeAndNil(frm);
end; //try-finally
end;
procedure TForm1.btnExportClick(Sender: TObject);
var
cry : TCrystalActiveXReportViewer;
oRpt, oApp : variant;
i : integer;
begin
//Export the report to a file
cry := TCrystalActiveXReportViewer.Create(Self);
oApp := CreateOleObject('CrystalRuntime.Application');
oRpt := oApp.OpenReport(c_DBRpt,1);
for i := 1 to oRpt.Database.Tables.Count do begin
oRpt.Database.Tables[i].ConnectionProperties.Item['User ID'] := 'username';
oRpt.Database.Tables[i].ConnectionProperties.Item['Password'] := 'password';
end;
oRpt.ExportOptions.FormatType := 29; //excel 8
oRpt.ExportOptions.DiskFileName := 'c:\output.xls';
oRpt.ExportOptions.DestinationType := 1; //file destination
//Export(False) => do NOT prompt.
//Export(True) will give runtime prompts for export options.
oRpt.Export(False);
end;
If you use this method, then this (rather dense) reference will be helpful, especially since Intellisense doesn't work on Ole objects like these.
Edit: The original link to the reference broke, so I changed it to point to a new one (valid as of Dec 15 2009). If that new one breaks, then Google should be able to find it.
I know it's not your question and it might not be an acceptable answer at all in your situation, but I have found FastReports to be clearly superior to Crystal for my purposes. It's lighter weight, includes a real scripting language, incorporates event handling, can make calls into your native code for information and updates and does not require an ActiveX connection. I can export my reports into sharp looking PDF files or Excel spreadsheets and several other formats. The quality of the output adds to the overall experience users get from my application. I could go on, but if it's off topic for you, it won't be helpful.
For the sake of anyone else who can use it, here is a complete class that gives a pleasant wrapper around these vile Crystal interactions. It works for me about 80% of the time, but I suspect a lot of this stuff is very dependent on the specific platform on which it runs. I'll post improvements as I make them.
Somebody at Business Objects should really take a hard look at this API. It sucks pretty badly.
{
Class to facilitate the display of Crystal 11 Reports.
The Crystal 11 VCL component does not seem to work with Delphi 2007.
As a result, we have to use ActiveX objects, which make deployment messy.
This class is similar to CrystalReporter, but it works for Crystal 11.
However, it lacks some of the features of the old CrystalReporter.
Refer to the crystal reports activex technical reference to duplicate the
missing functionality.
Example usage is at the bottom of this unit.
//}
unit CrystalReporter11;
interface
uses
CrystalActiveXReportViewerLib11_5_TLB, OleAuto, Classes, Controls;
type
TCryExportFormat = (
XLS
,PDF
);
type
TCrystalReporter11 = class
private
FCryRpt : TCrystalActiveXReportViewer;
FRpt, FApp : variant;
FReportFile, FUsername, FPassword, FServer, FFilters : string;
FOwner : TComponent;
procedure SetLoginInfo(const username, password, server : string);
function GetFilterConds: string;
procedure SetFilterConds(const Value: string);
public
property FilterConditions : string read GetFilterConds write SetFilterConds;
procedure ExportToFile(ExportFileName : string;
FileExportFmt : TCryExportFormat; PromptForOptions : boolean);
procedure Display;
constructor Create(AOwner : TComponent; ReportFile : string); overload;
constructor Create(AOwner : TComponent; ReportFile,
Username, Password, Server : string); overload;
end;
implementation
uses
SysUtils, Forms;
const
//these are taken from pgs 246 and 247 of the technical reference
c_FmtCode_Excel = 29;
c_FmtCode_PDF = 31;
constructor TCrystalReporter11.Create(AOwner: TComponent; ReportFile: string);
begin
inherited Create;
try
FReportFile := ReportFile;
if FileExists(FReportFile) then begin
FOwner := AOwner;
FCryRpt := TCrystalActiveXReportViewer.Create(AOwner);
FApp := CreateOleObject('CrystalRuntime.Application');
FRpt := FApp.OpenReport(FReportFile,1);
FFilters := FRpt.RecordSelectionFormula;
end
else begin
raise Exception.Create('Report file ' + ReportFile + ' not found!');
end;
except on e : exception do
raise;
end; //try-except
end;
constructor TCrystalReporter11.Create(AOwner: TComponent; ReportFile, Username,
Password, Server: string);
begin
Create(AOwner,ReportFile);
FUsername := Username;
FPassword := Password;
FServer := Server;
SetLoginInfo(FUsername,FPassword,FServer);
end;
procedure TCrystalReporter11.Display;
var
rptForm : TForm;
begin
SetLoginInfo(FUsername,FPassword,FServer);
FCryRpt.ReportSource := FRpt;
rptForm := TForm.Create(FOwner);
try
FCryRpt.Parent := rptForm;
FCryRpt.Align := alClient;
FCryRpt.ViewReport;
rptForm.Position := poOwnerFormCenter;
rptForm.WindowState := wsMaximized;
rptForm.Caption := ExtractFileName(FReportFile);
rptForm.ShowModal;
finally
FreeAndNil(rptForm);
end; //try-finally
end;
procedure TCrystalReporter11.ExportToFile(ExportFileName : string;
FileExportFmt : TCryExportFormat; PromptForOptions : boolean);
begin
case FileExportFmt of
XLS : FRpt.ExportOptions.FormatType := c_FmtCode_Excel;
PDF : FRpt.ExportOptions.FormatType := c_FmtCode_PDF;
end; //case
FRpt.ExportOptions.DiskFileName := ExportFileName;
FRpt.ExportOptions.DestinationType := 1; //file destination
FCryRpt.ReportSource := FRpt;
FRpt.Export(PromptForOptions);
end;
function TCrystalReporter11.GetFilterConds: string;
begin
Result := FFilters;
end;
procedure TCrystalReporter11.SetFilterConds(const Value: string);
begin
FFilters := Value;
if 0 < Length(Trim(FFilters)) then begin
FRpt.RecordSelectionFormula := Value;
end;
end;
procedure TCrystalReporter11.SetLoginInfo(const username, password,
server : string);
var
i : integer;
begin
//set user name and password
//crystal only accepts these values if they are CONST params
for i := 1 to FRpt.Database.Tables.Count do begin
FRpt.Database.Tables[i].ConnectionProperties.Item['User ID'] := username;
FRpt.Database.Tables[i].ConnectionProperties.Item['Password'] := password;
try
{
Some reports use direct connections, and others use an ODBC Data Source.
Crystal XI uses a different label to refer to the database name in each
method.
I don't know how to determine in advance which method is being used, so:
First, we try the direct connection.
If that fails, we try the "data source" method.
Reference: "Crystal Reports XI Technical Reference", pages 41 thru 46;
"Common ConnectionProperties"
}
FRpt.Database.Tables[i].ConnectionProperties.Item['Server'] := server;
except on E: Exception do
FRpt.Database.Tables[i].ConnectionProperties.Item['Data Source'] := server;
end;
end;
end;
{
Example usage:
procedure TForm1.btnShowRptDBClick(Sender: TObject);
var
cry : TCrystalReporter11;
begin
cry := TCrystalReporter11.Create(Self,'c:\my_report.rpt','username',
'password','server.domain.com');
try
cry.Display;
finally
FreeAndNil(cry);
end;
end;
}
end.
I too have been disappointed with the lack of effort by Crystal Reports with respect to application integration. I use the RDC, and from what I understand this is being deprecated and emphasis is being placed on .Net.
My application has these files in the uses clause:
CRRDC, CRAXDRT_TLB,
It works ok. The because drawback is parameter passing. In my option the parameter dialog boxes which come with the viewer are terrible. So I use my own Delphi application to prompt for parameters and pass them to the report.
Here is a bit simpler and clean class which solves the problem very nicely:
Unit CrystalReports;
uses Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.OleCtrls, ActiveX, ComObj, Data.DB, Data.Win.ADODB,
CrystalActiveXReportViewerLib11_TLB, Vcl.OleServer, CrystalReportsControllersLib_TLB;
type
TCrystalReportForm = class(TForm)
CRV: TCrystalActiveXReportViewer;
procedure DisplayReport;
private
{ Private declarations }
public
{Public declarations }
ReportName : WideString;
ReportCaption : String;
ReportSelectionFormula : WideString;
end;
var
CRXIRuntime : Variant;
implementation
{$R *.dfm}
procedure TCrystalReportForm.DisplayReport;
var
CrystalReport : variant;
i : integer;
begin
CrystalReport := CRXIRuntime.OpenReport(ReportName);
for i := 1 to CrystalReport.Database.Tables.Count do begin
CrystalReport.Database.Tables[1].ConnectionProperties.Item['User ID'] := 'user';
CrystalReport.Database.Tables[1].ConnectionProperties.Item['Password'] := 'password';
end;
CrystalReport.FormulaSyntax := 0;
Caption := ReportCaption;
CrystalReport.RecordSelectionFormula := ReportSelectionFormula;
CRV.Align := alClient;
CRV.ReportSource := CrystalReport;
WindowState := wsMaximized;
CRV.ViewReport;
ShowModal;
end;
begin
CRXIRuntime := CreateOleObject('CrystalRuntime.Application');
end.