Unit Ads_Misc;
{Copyright(c)2016 Advanced Delphi Systems
Richard Maley
Advanced Delphi Systems
12613 Maidens Bower Drive
Potomac, MD 20854 USA
phone 301-840-1554
dickmaley@advdelphisys.com
The code herein can be used or modified by anyone. Please retain references
to Richard Maley at Advanced Delphi Systems. If you make improvements to the
code please send your improvements to dickmaley@advdelphisys.com so that the
entire Delphi community can benefit. All comments are welcome.
}
(*UnitIndex Master Index Implementation Section Download UnitsDescription: ads_Misc.pas This unit contains the following routines.
DelphiCheck DelphiChecker DelphiIsRunning IsDelphiRunning Keybd_Event KeySend Msg MsgDlg PostVirtualKeyEvent_1 PostVirtualKeyEvent_2 ReSizeTuner SendKey TEditKeyFilter.OnlyAToZ TEditKeyFilter.OnlyNumbers TEditKeyFilter.OnlyNumbersAbsolute TForm1.Button1Click_1 TForm1.Button1Click_2 TForm1.Button1Click_3 TPanel_Cmp_Sec_ads.ResizeShadowLabel UserIDFromWindows VersionInformation
*)
Interface
Uses
SysUtils, StdCtrls, ExtCtrls, Ads_Strg, WinProcs, WinTypes, Dialogs,
Forms, Controls;
{!~ Checks whether Delphi is Running and
issues a message if the user doesn't have
the right to use the component}
procedure DelphiCheck(CanRunOutSide: Boolean);
{!~ Checks whether Delphi is Running and
issues a message if the user doesn't have
the right to use the component}
procedure DelphiChecker(
CanRunOutSide : Boolean;
ComponentName : String;
OwnerName : String;
PurchaseMessage : String;
ActivateDate : String);
{!~ Returns True if delphi is running, False otherwise}
Function DelphiIsRunning: Boolean;
{!~ Returns True if Delphi is currently running}
Function IsDelphiRunning: Boolean;
{!~ Allows the programmer to simulate
a keyboard press of a virtual key.
Only one key at a time.}
Function KeySend(VirtualKey: Word): Boolean;
{!~ Presents a Message Dialog}
procedure Msg(Msg: String);
{This Message Dialog exactly the same as MessageDlg provided in the delphi VCL
except that there is one more parameter at the end for the dafault button.
example:
procedure TForm1.Button1Click(Sender: TObject);
begin
If MsgDlg(
'This is my message',
mtInformation,
[mbYes,mbNo],
1,
mbNo) = mrYes Then
Begin
ShowMessage('Yes');
End
Else
Begin
ShowMessage('No');
End;
end;
}
function MsgDlg(const Msg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; HelpCtx: Longint; DefaultButton : TMsgDlgBtn): Integer;
{!~ Implements final resize tuning}
Procedure ReSizeTuner(ComponentName : String);
{!~ Allows the programmer to simulate
a keyboard press of a virtual key.
Only one key at a time.}
Function SendKey(VirtualKey: Word): Boolean;
{!~ Returns the Windows User ID.}
Function UserIDFromWindows: string;
{!~ Populates a listbox with the executable's version information}
Function VersionInformation(
ListBox : TListBox): Boolean;
Const RunOutsideIDE_ads = True;
Const RunOutsideIDEDate_ads = '12/31/2099';
Const RunOutsideIDECompany_ads = 'Advanced Delphi Systems';
Const RunOutsideIDEPhone_ads = 'Please purchase at (301) 840-1554';
implementation
Uses ads_Dialogs;
Type
TPanel_Cmp_Sec_ads = class(TPanel)
Public
procedure ResizeShadowLabel(Sender: TObject);
End;
//Unit Description UnitIndex Master Index
procedure TPanel_Cmp_Sec_ads.ResizeShadowLabel(
Sender : TObject);
Var
PH, PW : Integer;
LH, LW : Integer;
begin
PH := TPanel(Sender).Height;
PW := TPanel(Sender).Width;
LH := TLabel(Controls[0]).Height;
LW := TLabel(Controls[0]).Width;
TLabel(Controls[0]).Top := ((PH-LH) div 2)-3;
TLabel(Controls[0]).Left := ((Pw-Lw) div 2)-3;
end;
Type
TEditKeyFilter = Class(TEdit)
Published
{!~ Throws away all keys except 0-9,-,+,.}
Procedure OnlyNumbers(Sender: TObject; var Key: Char);
{!~ Throws away all keys except 0-9}
Procedure OnlyNumbersAbsolute(Sender: TObject; var Key: Char);
{!~ Throws away all keys except a-z and A-Z}
Procedure OnlyAToZ(Sender: TObject; var Key: Char);
End;
{$ifndef WIN32}
//Unit Description UnitIndex Master Indexprocedure Keybd_Event; far; external 'USER' index 289; //Unit Description UnitIndex Master Index
procedure PostVirtualKeyEvent(vk: Word; fUp: Bool);
var
AXReg, BXReg: WordRec;
const
ButtonUp: array[False..True] of Byte = (0, $80);
begin
AXReg.Hi := ButtonUp[fUp];
AXReg.Lo := vk;
BXReg.Hi := 0; { not an extended scan code }
BXReg.Lo := MapVirtualKey(vk, 0);
{ Special processing for the PrintScreen key. If scan code }
{ is set to 1 it copies entire screen. If set to 0 it }
{ copies active window. We'll just set it to 0 for now }
if AXReg.Lo = vk_SnapShot then
BXReg.Lo := 0;
asm
mov ax, AXReg
mov bx, BXReg
call Keybd_Event
end;
end;
{$else}
//Unit Description UnitIndex Master Index
procedure PostVirtualKeyEvent(vk: Word; fUp: Bool);
const
ButtonUp: array[False..True] of Byte = (0, KEYEVENTF_KEYUP);
var
ScanCode: Byte;
begin
if vk <> vk_SnapShot then
ScanCode := MapVirtualKey(vk, 0)
else
{ Special processing for the PrintScreen key. If scan code }
{ is set to 1 it copies entire screen. If set to 0 it }
{ copies active window. We'll just set it to 0 for now }
ScanCode := 0;
Keybd_Event(vk, ScanCode, ButtonUp[fUp], 0);
end;
{$endif}
{!~ Throws away all keys except 0-9,-,+,.}
//Unit Description UnitIndex Master Index
Procedure TEditKeyFilter.OnlyNumbers(Sender: TObject; var Key: Char);
Begin
KeyPressOnlyNumbers(Key);
End;
{!~ Throws away all keys except 0-9}
//Unit Description UnitIndex Master Index
Procedure TEditKeyFilter.OnlyNumbersAbsolute(Sender: TObject; var Key: Char);
Begin
KeyPressOnlyNumbersAbsolute(Key);
End;
{!~ Throws away all keys except a-z and A-Z}
//Unit Description UnitIndex Master Index
Procedure TEditKeyFilter.OnlyAToZ(Sender: TObject; var Key: Char);
Begin
KeyPressOnlyAToZ(Key);
End;
{!~ Checks whether Delphi is Running and
issues a message if the user doesn't have
the right to use the component}
//Unit Description UnitIndex Master Index
procedure DelphiCheck(CanRunOutSide: Boolean);
var WindHand : THandle;
wcnPChar : array[0..32] of char;
ClName : array[0..32] of char;
Begin
If CanRunOutSide Then Exit;
StrPLCopy(wcnPChar,'TApplication',13);
{$IFDEF WIN32}
StrPLCopy(ClName,'Delphi 2.0',11);
{$ELSE}
StrPLCopy(ClName,'Delphi',7);
{$ENDIF}
WindHand := FindWindow(wcnPChar,ClName);
If WindHand = 0 Then
Begin
MessageDlg(
'The T*_ads component belongs to Advanced Delphi Systems!',
mtInformation,
[mbOk], 0);
MessageDlg(
'Please purchase at (301)840-1554',
mtInformation,
[mbOk], 0);
End;
End;
{!~ Checks whether Delphi is Running and
issues a message if the user doesn't have
the right to use the component}
//Unit Description UnitIndex Master Index
procedure DelphiChecker(
CanRunOutSide : Boolean;
ComponentName : String;
OwnerName : String;
PurchaseMessage : String;
ActivateDate : String);
var WindHand : THandle;
wcnPChar : array[0..32] of char;
ClName : array[0..32] of char;
Begin
If CanRunOutSide Then Exit;
StrPLCopy(wcnPChar,'TApplication',13);
{$IFDEF WIN32}
StrPLCopy(ClName,'Delphi 2.0',11);
{$ELSE}
StrPLCopy(ClName,'Delphi',7);
{$ENDIF}
WindHand := FindWindow(wcnPChar,ClName);
If WindHand = 0 Then
Begin
If Date > StrToDate(ActivateDate) Then
Begin
MessageDlg(
ComponentName+' belongs to '+OwnerName+'!',
mtInformation,
[mbOk], 0);
MessageDlg(
PurchaseMessage,
mtInformation,
[mbOk], 0);
End;
End;
End;
{!~ Returns True if delphi is running, False otherwise}
//Unit Description UnitIndex Master Index
Function DelphiIsRunning: Boolean;
var WindHand : THandle;
wcnPChar : array[0..32] of char;
ClName : array[0..32] of char;
Begin
StrPLCopy(wcnPChar,'TApplication',13);
{$IFDEF WIN32}
StrPLCopy(ClName,'Delphi 2.0',11);
{$ELSE}
StrPLCopy(ClName,'Delphi',7);
{$ENDIF}
WindHand := FindWindow(wcnPChar,ClName);
If WindHand = 0 Then
Begin
Result := false;
End
Else
Begin
Result := True;
End;
End;
{!~ Returns True if Delphi is currently running}
//Unit Description UnitIndex Master Index
Function IsDelphiRunning: Boolean;
Begin
Result := DelphiIsRunning;
End;
{!~ Allows the programmer to simulate
a keyboard press of a virtual key.
Only one key at a time.}
//Unit Description UnitIndex Master Index
Function KeySend(VirtualKey: Word): Boolean;
Begin
Result := SendKey(VirtualKey);
End;
(*
This example moves the current cell in the stringgrid down 1
when the button is pressed.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids, StdCtrls, ads_Sendkey;
type
TForm1 = class(TForm)
Button1: TButton;
StringGrid1: TStringGrid;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
//Unit Description UnitIndex Master Index
procedure TForm1.Button1Click(Sender: TObject);
begin
ActiveControl := StringGrid1;
KeySend(VK_Down);
end;
end.
*)
{!~ Presents a Message Dialog}
//Unit Description UnitIndex Master Index
procedure Msg(Msg: String);
Begin
MessageDlg(
Msg,
mtInformation,
[mbOk], 0);
End;
{!~ Implements final resize tuning}
//Unit Description UnitIndex Master Index
Procedure ReSizeTuner(ComponentName : String);
Begin
DelphiChecker(
RunOutsideIDE_ads,
ComponentName,
RunOutsideIDECompany_ads,
RunOutsideIDEPhone_ads,
RunOutsideIDEDate_ads);
End;
{!~ Allows the programmer to simulate
a keyboard press of a virtual key.
Only one key at a time.}
//Unit Description UnitIndex Master Index
Function SendKey(VirtualKey: Word): Boolean;
Begin
Try
PostVirtualKeyEvent(VirtualKey,False);
PostVirtualKeyEvent(VirtualKey,True);
Result := True;
Except
Result := False;
End;
End;
(*
This example moves the current cell in the stringgrid down 1
when the button is pressed.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Grids, StdCtrls, ads_Sendkey;
type
TForm1 = class(TForm)
Button1: TButton;
StringGrid1: TStringGrid;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
//Unit Description UnitIndex Master Index
procedure TForm1.Button1Click(Sender: TObject);
begin
ActiveControl := StringGrid1;
SendKey(VK_Down);
end;
end.
*)
{!~ Returns the Windows User ID.}
//Unit Description UnitIndex Master Index
Function UserIDFromWindows: string;
Var
UserName : string;
UserNameLen : Dword;
Begin
UserNameLen := 255;
SetLength(userName, UserNameLen);
If GetUserName(PChar(UserName), UserNameLen) Then
Result := Copy(UserName,1,UserNameLen - 1)
Else
Result := 'Unknown';
End;
{!~ Populates a listbox with the executable's version information}
//Unit Description UnitIndex Master Index
Function VersionInformation(
ListBox : TListBox): Boolean;
const
InfoNum = 11;
InfoStr : array [1..InfoNum] of String =
('CompanyName', 'FileDescription', 'FileVersion', 'InternalName',
'LegalCopyright', 'LegalTradeMarks', 'OriginalFilename',
'ProductName', 'ProductVersion', 'Comments', 'Author');
LabelStr : array [1..InfoNum] of String =
('Company Name', 'Description', 'File Version', 'Internal Name',
'Copyright', 'TradeMarks', 'Original File Name',
'Product Name', 'Product Version', 'Comments', 'Author');
var
S : String;
n, Len, i : Integer;
Buf : PChar;
Value : PChar;
begin
Try
S := Application.ExeName;
ListBox.Items.Clear;
ListBox.Sorted := True;
ListBox.Font.Name := 'Courier New';
n := GetFileVersionInfoSize(PChar(S),Cardinal(n));
If n > 0 Then
Begin
Buf := AllocMem(n);
ListBox.Items.Add(StringPad('Size',' ',20,True)+' = '+IntToStr(n));
GetFileVersionInfo(PChar(S),0,n,Buf);
For i:=1 To InfoNum Do
Begin
If VerQueryValue(Buf,PChar('StringFileInfo\040904E4\'+
InfoStr[i]),Pointer(Value),Cardinal(Len)) Then
Begin
//Value := PChar(Trim(Value));
If Length(Value) > 0 Then
Begin
ListBox.Items.Add(StringPad(labelStr[i],' ',20,True)+' = '+Value);
End;
End;
End;
FreeMem(Buf,n);
End
Else
Begin
ListBox.Items.Add('No FileVersionInfo found');
End;
Result := True;
Except
Result := False;
End;
End;
{
MsgDlg
This Message Dialog is exactly the same as MessageDlg provided in the delphi
VCL except that there is one more parameter at the end for the dafault button.
example:
//Unit Description UnitIndex Master Index
procedure TForm1.Button1Click(Sender: TObject);
begin
If MsgDlg(
'This is my message',
mtInformation,
[mbYes,mbNo],
1,
mbNo) = mrYes Then
Begin
ShowMessage('Yes');
End
Else
Begin
ShowMessage('No');
End;
end;
}
//Unit Description UnitIndex Master Indexfunction MsgDlg(const Msg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint; DefaultButton : TMsgDlgBtn): Integer; begin Result := ads_Dialogs.Msg_Dlg(Msg,DlgType,Buttons,HelpCtx,DefaultButton); end; End. //