// caption及Label要設定為螢幕字型及語言，Button不同，會依照form來決定字型
self.Font.Name := Screen.MenuFont.Name;
self.Font.Charset := Screen.MenuFont.Charset;
Caption := _sArray[_L_ExportCaption];
Label1.Font.Name :=Screen.MenuFont.Name;
Label1.Font.Charset :=Screen.MenuFont.Charset;
Label1.Caption := _sArray[_L_ExportPleaseSel];
procedure TForm1.Button1Click(Sender: TObject);
var
HWND:THandle;
dc:HDC ;
rect:TRect ;
dest:TBitmap;
jpg :TJpegImage;
w, h : integer;
begin
HWND:=handle;
GetWindowRect(HWND,rect);
dc:=GetWindowDC(HWND);
dest := TBitmap.Create;
jpg := TJpegImage.create;
w := rect.Right-rect.Left;
h := rect.Bottom-rect.Top;
dest.Width := w;
dest.height := h;
try
BitBlt(dest.canvas.handle,0,0,w,h,dc,0,0,SRCCOPY );
jpg.Assign(dest);
jpg.CompressionQuality:=100;
jpg.JPEGNeeded;
jpg.Compress;
jpg.SaveToFile('c:\1.jpg');
finally
ReleaseDC(HWND,dc);
jpg.free;
dest.Free;
end;
end;
var
g_dtTimeZoneInfo:TIME_ZONE_INFORMATION ;
function GetTimeZoneInfo():boolean ;//取得utc時間
begin
Result := (TIME_ZONE_ID_INVALID<>GetTimeZoneInformation(g_dtTimeZoneInfo) ) ;
end ;
function LocalTimeToUTC(const dtLocalTime: TDateTime) : TDateTime ;
begin
Result := IncMinute(dtLocalTime, g_dtTimeZoneInfo.Bias ) ;
end ;
function UTCToLocalTime(const dtUTC: TDateTime) : TDateTime ;
begin
Result := IncMinute(dtUTC, -g_dtTimeZoneInfo.Bias ) ;
end ;
function UTCNow(): TDateTime;
var
st: SYSTEMTIME;
begin
GetSystemTime(st);
Result:=SystemTimeToDateTime(st);
end;
//---------------------------------------------------------------------------
function UTCDate(): TDateTime;
var
st: SYSTEMTIME;
begin
GetSystemTime(st);
Result:=EncodeDate(st.wYear, st.wMonth, st.wDay);
end;
function ValidDrive( driveletter: Char ): Boolean;
var
mask: String[6];
sRec: TSearchRec;
oldMode: Cardinal;
retcode: Integer;
begin
oldMode :=SetErrorMode( SEM_FAILCRITICALERRORS );
mask:= '?:\*.*';
mask[1] := driveletter;
{$I-} { don't raise exceptions if we fail }
retcode := FindFirst( mask, faAnyfile, SRec );
if retcode = 0 then
FindClose( SRec );
{$I+}
Result := Abs(retcode) in
[ERROR_SUCCESS,ERROR_FILE_NOT_FOUND,ERROR_NO_MORE_FILES];
SetErrorMode( oldMode );
end; { ValidDrive }
procedure TFormMain.SpinTotalTimeKeyPress(Sender: TObject;var Key: Char);
begin
if (Key='-') or (Key='.') or (Key='+') then Key:=char(0);
end;
function CheckLegalSpinValue( var spin:TSpinEdit; var Key:Word ):boolean;overload;
begin
//if not( Key in [$9, $30..$57, $60..$69, $D, $A, $25, $27, $90, VK_BACK, VK_DELETE] ) then
//應觀眾要求修改 20070625 Ma
if not( Key in [$9, $30..$57, $60..$69, $D, $A, $25, $26, $27, $28, $90, VK_BACK, VK_DELETE] ) then
begin
OneBtnMsgBox(g_saMsg[27], MB_ICONSTOP) ; // '請輸入合法的數字'
spin.Value := 0 ;
Result := false ; // defined in windows
Exit ;
end ;
Result := true ;
end ;
{ check if the input in TSpinEdit is legal }
function CheckLegalSpinValue( var spin:TSpinEdit):boolean;overload;
begin
if( IsLegalInt(spin.Text) ) then
Result := true
else
Result := false ;
end ;
procedure TFrame3.SpinEdit1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if( not CheckLegalSpinValue(SpinEdit1, Key) ) then
Exit;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
i : double;
j : integer;
want_money : integer;
begin
if Edit2.text='0' then
j := 1
else
j := strtoint(Edit2.text);
i := trunc(j*strtofloat(Edit1.Text)/1200+0.4)+0.5;
want_money := trunc(i*1200/strtofloat(Edit1.Text)+0.5);
Label3.Caption := floattostr(want_money);
Label4.Caption := floattostr((i+0.5)*1200/want_money);
Label5.Caption := floattostr(i+0.5);
end;
unit fmTest;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, adCpuUsage, ExtCtrls;
type
TTestForm = class(TForm)
MInfo: TMemo;
LbAldynUrl: TLabel;
Timer: TTimer;
procedure LbAldynUrlClick(Sender: TObject);
procedure TimerTimer(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
TestForm: TTestForm;
implementation
{$R *.DFM}
uses shellapi;
procedure TTestForm.LbAldynUrlClick(Sender: TObject);
begin
ShellExecute(Application.Handle, 'open', 'http://www.aldyn.ru/',
nil, nil, SW_SHOWDEFAULT);
end;
procedure TTestForm.TimerTimer(Sender: TObject);
var i: Integer;
begin
CollectCPUData;
MInfo.Lines.BeginUpdate;
for i:=0 to GetCPUCount-1 do
MInfo.Lines[i+1]:=Format('CPU #%d - %5.2f%%',[i,GetCPUUsage(i)*100]);
MInfo.Lines.EndUpdate;
end;
procedure TTestForm.FormCreate(Sender: TObject);
var i: Integer;
begin
MInfo.Lines.Clear;
MInfo.Lines.Add(Format('There are %d total CPU in your system',[GetCPUCount]));
for i:=0 to GetCPUCount-1 do MInfo.Lines.Add('');
end;
end.
unit adCpuUsage;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
CPU Usage Measurement routines for Delphi and C++ Builder
Author: Alexey A. Dynnikov
EMail: aldyn@chat.ru
WebSite: http://www.aldyn.ru/
Support: Use the e-mail aldyn@chat.ru
or support@aldyn.ru
Creation: Jul 8, 2000
Version: 1.02
Legal issues: Copyright (C) 2000 by Alexey A. Dynnikov
This software is provided 'as-is', without any express or
implied warranty. In no event will the author be held liable
for any damages arising from the use of this software.
Permission is granted to anyone to use this software for any
purpose, including commercial applications, and to alter it
and redistribute it freely, subject to the following
restrictions:
1. The origin of this software must not be misrepresented,
you must not claim that you wrote the original software.
If you use this software in a product, an acknowledgment
in the product documentation would be appreciated but is
not required.
2. Altered source versions must be plainly marked as such, and
must not be misrepresented as being the original software.
3. This notice may not be removed or altered from any source
distribution.
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
USAGE:
1. Include this unit into project.
2. Call GetCPUCount to obtain the numbr of processors in the system
3. Each time you need to know the value of CPU usage call the CollectCPUData
to refresh the CPU usage information. Then call the GetCPUUsage to obtain
the CPU usage for given processor. Note that succesive calls of GetCPUUsage
without calling CollectCPUData will return the same CPU usage value.
Example:
procedure TTestForm.TimerTimer(Sender: TObject);
var i: Integer;
begin
CollectCPUData; // Get the data for all processors
for i:=0 to GetCPUCount-1 do // Show data for each processor
MInfo.Lines[i]:=Format('CPU #%d - %5.2f%%',[i,GetCPUUsage(i)*100]);
end;
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
interface
uses
Windows, SysUtils;
// Call CollectCPUData to refresh information about CPU usage
procedure CollectCPUData;
// Call it to obtain the number of CPU's in the system
function GetCPUCount: Integer;
// Call it to obtain the % of usage for given CPU
function GetCPUUsage(Index: Integer): Double;
// For Win9x only: call it to stop CPU usage monitoring and free system resources
procedure ReleaseCPUData;
implementation
{$ifndef ver110}
{$ifndef ver90}
{$ifndef ver100}
{$define UseInt64}
{$endif}
{$endif}
{$ifdef UseInt64}
type TInt64 = Int64;
{$else}
type TInt64 = Comp;
{$endif}
{$else}
type TInt64 = TLargeInteger;
{$endif}
type
PInt64 = ^TInt64;
type
TPERF_DATA_BLOCK = record
Signature : array[0..4 - 1] of WCHAR;
LittleEndian : DWORD;
Version : DWORD;
Revision : DWORD;
TotalByteLength : DWORD;
HeaderLength : DWORD;
NumObjectTypes : DWORD;
DefaultObject : Longint;
SystemTime : TSystemTime;
Reserved: DWORD;
PerfTime : TInt64;
PerfFreq : TInt64;
PerfTime100nSec : TInt64;
SystemNameLength : DWORD;
SystemNameOffset : DWORD;
end;
PPERF_DATA_BLOCK = ^TPERF_DATA_BLOCK;
TPERF_OBJECT_TYPE = record
TotalByteLength : DWORD;
DefinitionLength : DWORD;
HeaderLength : DWORD;
ObjectNameTitleIndex : DWORD;
ObjectNameTitle : LPWSTR;
ObjectHelpTitleIndex : DWORD;
ObjectHelpTitle : LPWSTR;
DetailLevel : DWORD;
NumCounters : DWORD;
DefaultCounter : Longint;
NumInstances : Longint;
CodePage : DWORD;
PerfTime : TInt64;
PerfFreq : TInt64;
end;
PPERF_OBJECT_TYPE = ^TPERF_OBJECT_TYPE;
type
TPERF_COUNTER_DEFINITION = record
ByteLength : DWORD;
CounterNameTitleIndex : DWORD;
CounterNameTitle : LPWSTR;
CounterHelpTitleIndex : DWORD;
CounterHelpTitle : LPWSTR;
DefaultScale : Longint;
DetailLevel : DWORD;
CounterType : DWORD;
CounterSize : DWORD;
CounterOffset : DWORD;
end;
PPERF_COUNTER_DEFINITION = ^TPERF_COUNTER_DEFINITION;
TPERF_COUNTER_BLOCK = record
ByteLength : DWORD;
end;
PPERF_COUNTER_BLOCK = ^TPERF_COUNTER_BLOCK;
TPERF_INSTANCE_DEFINITION = record
ByteLength : DWORD;
ParentObjectTitleIndex : DWORD;
ParentObjectInstance : DWORD;
UniqueID : Longint;
NameOffset : DWORD;
NameLength : DWORD;
end;
PPERF_INSTANCE_DEFINITION = ^TPERF_INSTANCE_DEFINITION;
//------------------------------------------------------------------------------
{$ifdef ver130}
{$L-} // The L+ causes internal error in Delphi 5 compiler
{$O-} // The O+ causes internal error in Delphi 5 compiler
{$Y-} // The Y+ causes internal error in Delphi 5 compiler
{$endif}
{$ifndef ver110}
type
TInt64F = TInt64;
{$else}
type
TInt64F = Extended;
{$endif}
{$ifdef ver110}
function FInt64(Value: TInt64): TInt64F;
function Int64D(Value: DWORD): TInt64;
{$else}
type
FInt64 = TInt64F;
Int64D = TInt64;
{$endif}
{$ifdef ver110}
function FInt64(Value: TInt64): TInt64F;
var V: TInt64;
begin
if (Value.HighPart and $80000000) = 0 then // positive value
begin
result:=Value.HighPart;
result:=result*$10000*$10000;
result:=result+Value.LowPart;
end else
begin
V.HighPart:=Value.HighPart xor $FFFFFFFF;
V.LowPart:=Value.LowPart xor $FFFFFFFF;
result:= -1 - FInt64(V);
end;
end;
function Int64D(Value: DWORD): TInt64;
begin
result.LowPart:=Value;
result.HighPart := 0; // positive only
end;
{$endif}
//------------------------------------------------------------------------------
const
Processor_IDX_Str = '238';
Processor_IDX = 238;
CPUUsageIDX = 6;
type
AInt64F = array[0..$FFFF] of TInt64F;
PAInt64F = ^AInt64F;
var
_PerfData : PPERF_DATA_BLOCK;
_BufferSize: Integer;
_POT : PPERF_OBJECT_TYPE;
_PCD: PPerf_Counter_Definition;
_ProcessorsCount: Integer;
_Counters: PAInt64F;
_PrevCounters: PAInt64F;
_SysTime: TInt64F;
_PrevSysTime: TInt64F;
_IsWinNT: Boolean;
_W9xCollecting: Boolean;
_W9xCpuUsage: DWORD;
_W9xCpuKey: HKEY;
//------------------------------------------------------------------------------
function GetCPUCount: Integer;
begin
if _IsWinNT then
begin
if _ProcessorsCount < 0 then CollectCPUData;
result:=_ProcessorsCount;
end else
begin
result:=1;
end;
end;
//------------------------------------------------------------------------------
procedure ReleaseCPUData;
var H: HKEY;
R: DWORD;
dwDataSize, dwType: DWORD;
begin
if _IsWinNT then exit;
if not _W9xCollecting then exit;
_W9xCollecting:=False;
RegCloseKey(_W9xCpuKey);
R:=RegOpenKeyEx( HKEY_DYN_DATA, 'PerfStats\StopStat', 0, KEY_ALL_ACCESS, H );
if R <> ERROR_SUCCESS then exit;
dwDataSize:=sizeof(DWORD);
RegQueryValueEx ( H, 'KERNEL\CPUUsage', nil, @dwType, PBYTE(@_W9xCpuUsage), @dwDataSize);
RegCloseKey(H);
end;
//------------------------------------------------------------------------------
function GetCPUUsage(Index: Integer): Double;
begin
if _IsWinNT then
begin
if _ProcessorsCount < 0 then CollectCPUData;
if (Index >= _ProcessorsCount) or (Index < 0) then
raise Exception.Create('CPU index out of bounds');
if _PrevSysTime = _SysTime then result:=0 else
result:=1-(_Counters[index] - _PrevCounters[index])/(_SysTime-_PrevSysTime);
end else
begin
if Index <> 0 then
raise Exception.Create('CPU index out of bounds');
if not _W9xCollecting then CollectCPUData;
result:=_W9xCpuUsage / 100;
end;
end;
var VI: TOSVERSIONINFO;
//------------------------------------------------------------------------------
procedure CollectCPUData;
var BS: integer;
i: Integer;
_PCB_Instance: PPERF_COUNTER_BLOCK;
_PID_Instance: PPERF_INSTANCE_DEFINITION;
ST: TFileTime;
var H: HKEY;
R: DWORD;
dwDataSize, dwType: DWORD;
begin
if _IsWinNT then
begin
BS:=_BufferSize;
while RegQueryValueEx( HKEY_PERFORMANCE_DATA, Processor_IDX_Str, nil, nil,
PByte(_PerfData), @BS ) = ERROR_MORE_DATA do
begin
// Get a buffer that is big enough.
INC(_BufferSize,$1000);
BS:=_BufferSize;
ReallocMem( _PerfData, _BufferSize );
end;
// Locate the performance object
_POT := PPERF_OBJECT_TYPE(DWORD(_PerfData) + _PerfData.HeaderLength);
for i := 1 to _PerfData.NumObjectTypes do
begin
if _POT.ObjectNameTitleIndex = Processor_IDX then Break;
_POT := PPERF_OBJECT_TYPE(DWORD(_POT) + _POT.TotalByteLength);
end;
// Check for success
if _POT.ObjectNameTitleIndex <> Processor_IDX then
raise Exception.Create('Unable to locate the "Processor" performance object');
if _ProcessorsCount < 0 then
begin
_ProcessorsCount:=_POT.NumInstances;
GetMem(_Counters,_ProcessorsCount*SizeOf(TInt64));
GetMem(_PrevCounters,_ProcessorsCount*SizeOf(TInt64));
end;
// Locate the "% CPU usage" counter definition
_PCD := PPERF_Counter_DEFINITION(DWORD(_POT) + _POT.HeaderLength);
for i := 1 to _POT.NumCounters do
begin
if _PCD.CounterNameTitleIndex = CPUUsageIDX then break;
_PCD := PPERF_COUNTER_DEFINITION(DWORD(_PCD) + _PCD.ByteLength);
end;
// Check for success
if _PCD.CounterNameTitleIndex <> CPUUsageIDX then
raise Exception.Create('Unable to locate the "% of CPU usage" performance counter');
// Collecting coutners
_PID_Instance := PPERF_INSTANCE_DEFINITION(DWORD(_POT) + _POT.DefinitionLength);
for i := 0 to _ProcessorsCount-1 do
begin
_PCB_Instance := PPERF_COUNTER_BLOCK(DWORD(_PID_Instance) + _PID_Instance.ByteLength );
_PrevCounters[i]:=_Counters[i];
_Counters[i]:=FInt64(PInt64(DWORD(_PCB_Instance) + _PCD.CounterOffset)^);
_PID_Instance := PPERF_INSTANCE_DEFINITION(DWORD(_PCB_Instance) + _PCB_Instance.ByteLength);
end;
_PrevSysTime:=_SysTime;
SystemTimeToFileTime(_PerfData.SystemTime, ST);
_SysTime:=FInt64(TInt64(ST));
end else
begin
if not _W9xCollecting then
begin
R:=RegOpenKeyEx( HKEY_DYN_DATA, 'PerfStats\StartStat', 0, KEY_ALL_ACCESS, H );
if R <> ERROR_SUCCESS then
raise Exception.Create('Unable to start performance monitoring');
dwDataSize:=sizeof(DWORD);
RegQueryValueEx( H, 'KERNEL\CPUUsage', nil, @dwType, PBYTE(@_W9xCpuUsage), @dwDataSize );
RegCloseKey(H);
R:=RegOpenKeyEx( HKEY_DYN_DATA, 'PerfStats\StatData', 0,KEY_READ, _W9xCpuKey );
if R <> ERROR_SUCCESS then
raise Exception.Create('Unable to read performance data');
_W9xCollecting:=True;
end;
dwDataSize:=sizeof(DWORD);
RegQueryValueEx( _W9xCpuKey, 'KERNEL\CPUUsage', nil,@dwType, PBYTE(@_W9xCpuUsage), @dwDataSize );
end;
end;
initialization
_ProcessorsCount:= -1;
_BufferSize:= $2000;
_PerfData := AllocMem(_BufferSize);
VI.dwOSVersionInfoSize:=SizeOf(VI);
if not GetVersionEx(VI) then raise Exception.Create('Can''t get the Windows version');
_IsWinNT := VI.dwPlatformId = VER_PLATFORM_WIN32_NT;
finalization
ReleaseCPUData;
FreeMem(_PerfData);
end.
case TWMKey(Msg).CharCode of
VK_DELETE : BtnRealTimeDelete.Click;
VK_DOWN :
begin
if (LBRealTime.ItemIndex = LBRealTime.Count-1) or (LBRealTime.Count=0) then
exit;
LBRealTime.ItemIndex := LBRealTime.ItemIndex+1;
if GetKeyState(VK_SHIFT) >= 0 then //代表沒按shift
begin
for i:=0 to LBRealTime.Count-1 do
LBRealTime.Selected [i] := false;
g_RealTimeShift := false;
LBRealTime.Selected[LBRealTime.ItemIndex] := true;
end else
begin
for i:=0 to LBRealTime.Count-1 do
LBRealTime.Selected [i] := false;
g_RealTimeShift := true;
if g_RealTimeShiftRec<= LBRealTime.ItemIndex then
for i:=g_RealTimeShiftRec to LBRealTime.ItemIndex do
LBRealTime.Selected [i] := true
else
for i:=g_RealTimeShiftRec downto LBRealTime.ItemIndex do
LBRealTime.Selected [i] := true;
end;
LBRealTimeClick(self);
end;
VK_UP :
begin
if (LBRealTime.ItemIndex = 0) or (LBRealTime.Count=0) then
exit;
LBRealTime.ItemIndex := LBRealTime.ItemIndex-1;
if GetKeyState(VK_SHIFT) >= 0 then //代表沒按shift
begin
for i:=0 to LBRealTime.Count-1 do
LBRealTime.Selected [i] := false;
g_RealTimeShift := false;
LBRealTime.Selected[LBRealTime.ItemIndex] := true;
end else
begin
for i:=0 to LBRealTime.Count-1 do
LBRealTime.Selected [i] := false;
g_RealTimeShift := true;
if g_RealTimeShiftRec<= LBRealTime.ItemIndex then
for i:=g_RealTimeShiftRec to LBRealTime.ItemIndex do
LBRealTime.Selected [i] := true
else
for i:=g_RealTimeShiftRec downto LBRealTime.ItemIndex do
LBRealTime.Selected [i] := true;
end;
LBRealTimeClick(self);
end;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
case Key of
VK_DOWN: Perform(WM_NEXTDLGCTL, 0, 0);
VK_UP: Perform(WM_NEXTDLGCTL, 1, 0);
end;
end;
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function AsciiToAlpha(Source: String): String;
const
Alpha: array[32..126] of String = ( ' ', '！', '”','＃' ,'＄' ,'％','＆' ,'’' ,'（' ,'）','＊','＋', '，',
'－', '.', '／', '０', '１', '２', '３', '４', '５', '６','７', '８', '９',
'：', '；', '＜', '＝', '＞', '？', '＠' , 'Ａ', 'Ｂ', 'Ｃ', 'Ｄ', 'Ｅ', 'Ｆ',
'Ｇ', 'Ｈ', 'Ｉ', 'Ｊ','Ｋ', 'Ｌ', 'Ｍ', 'Ｎ', 'Ｏ', 'Ｐ', 'Ｑ', 'Ｒ', 'Ｓ',
'Ｔ', 'Ｕ', 'Ｖ', 'Ｗ', 'Ｘ', 'Ｙ', 'Ｚ', '〔', '＼', '〕', '︿','＿', '’',
'ａ', 'ｂ', 'ｃ', 'ｄ', 'ｅ', 'ｆ', 'ｇ', 'ｈ','ｉ', 'ｊ', 'ｋ', 'ｌ', 'ｍ',
'ｎ', 'ｏ', 'ｐ', 'ｑ', 'ｒ', 'ｓ', 'ｔ', 'ｕ', 'ｖ','ｗ','ｘ','ｙ','ｚ',
'｛', '｜', '｝', '～'
);
ASCII: array[32..126] of String = (
' ', '!', '"','#' ,'$' ,'%','&' ,'`' ,'(' ,')','*','+', ',',
'-', '.', '/', '0', '1','2', '3', '4', '5', '6','7', '8', '9',
':', ';','<', '=', '>', '?', '@', 'A', 'B', 'C', 'D', 'E','F',
'G', 'H', 'I', 'J','K', 'L', 'M', 'N', 'O','P', 'Q', 'R', 'S',
'T','U', 'V', 'W', 'X', 'Y','Z', '[', '\', ']', '^','_', '`',
'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm',
'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x','y','z',
'{', '|', '}', '~'
);
var
w:WideString;
ret:WideString;
i:integer;
begin
w:= Source;
i:=1;
ret := '';
for i := 1 to length(w) do
begin
if w[i] > #128 then
begin
ret := ret+ w[i];
end else begin
if ((Ord(w[i]) >=(32)) and (Ord(w[i])<=(126))) then
begin
ret := ret+ Alpha[ ord(w[i]) ];
end;
end;
end;
result := ret;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
caption := AsciiToAlpha('ＹＡＯ');
end;
end.
procedure TForm1.Button1Click(Sender: TObject);
var
dm: TDeviceMode;
Mode: string;
begin
Memo1.Clear;
Mode := '';
EnumDisplaySettings(nil, High(DWORD)-1, dm);
Mode := IntToStr(dm.dmBitsPerPel) + ' Bits Per Pixel ' +
IntToStr(dm.dmPelsWidth) + ' x ' +
IntToStr(dm.dmPelsHeight);
memo1.lines.Add(Mode);
end;
procedure GetVideoModes(ModeList: TStrings);
var
i, j: integer;
MoreModes,
AddMode: boolean;
dm: TDeviceMode;
Mode: string;
begin
ModeList.Clear;
MoreModes := True;
Mode := '';
i := 0;
while MoreModes do
begin
MoreModes := EnumDisplaySettings(nil, i, dm);
Mode := IntToStr(dm.dmBitsPerPel) + ' Bits Per Pixel ' +
IntToStr(dm.dmPelsWidth) + ' x ' +
IntToStr(dm.dmPelsHeight);
AddMode := True;
{ Check to make sure this mode is not already in the list. }
for j := 0 to ModeList.Count-1 do
if Mode = ModeList[j] then
AddMode := False;
if AddMode then
ModeList.Add(Mode);
Inc(i);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
GetVideoModes(memo1.lines);
end;
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, AppEvnts, StdCtrls, UnitTAA;
type
TForm1 = class(TForm)
Button1: TButton;
Button2: TButton;
ApplicationEvents1: TApplicationEvents;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
AAInit;
g_AA.TestHD:=Self.Handle;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
g_AA.Destroy;
end;
procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
begin
if Msg.message = WM_USER + 22 then
begin
Self.Caption:=IntToStr(Msg.wParam);
end;
end;
end.
unit UnitTAA;
interface
uses Windows, SysUtils, Classes, Graphics, ExtCtrls, Messages, UnitCommon;
const
TimerID_15 = 11111;
type
TAA = class(TObject)
private
{ Private declarations }
MyWinClass : TWndClass;
FMyHideHD : THandle;
FTestHd : THandle;
procedure Init;
public
{ Public declarations }
property MyHideHD : THandle read FMyHideHD;
property TestHD : THandle read FTestHD write FTestHd;
constructor Create;
destructor Destroy;
procedure OnTimer();
end;
procedure AAInit();
var
g_AA : TAA;
implementation
{ TAA }
function TAAWindowProc(hWnd:HWND; iMsg:Integer; wParam:WPARAM; lParam:LPARAM): Integer; stdcall;
var
uTimer : DWORD;
begin
Result:=0;
case iMsg of
WM_CREATE :
begin
uTimer:=SetTimer(hWnd,TimerID_15,1000,nil); //hWnd控制的把柄 TimerId_15標誌 nil指WM_TIMER將處理消息
//if(uTimer = 0) then
// Result:=-1;
exit;
end;
WM_DESTROY :
begin
KillTimer(hWnd, TimerID_15); //銷毀SetTimer建立的計時器
PostQuitMessage(0); //跟Windows說我要退出囉。
exit;
end;
WM_TIMER :
begin
g_AA.OnTimer();
exit;
end;
end;
Result := DefWindowProc(hWnd,iMsg,wParam,lParam); //不感興趣的消息，由windows去處理
end;
constructor TAA.Create;
var
uTimer : DWORD;
begin
DebugStr('TAA.Create');
inherited;
Init;
if IsWindow(FMyHideHD) then
begin
uTimer:=SetTimer(FMyHideHD,TimerID_15,1000,nil);
DebugStr('uTimer = ' + IntToStr(uTimer));
end;
end;
destructor TAA.Destroy;
begin
inherited;
if FMyHideHD <> 0 then
begin
KillTimer(FMyHideHD,TimerID_15);
DestroyWindow(FMyHideHD);
FMyHideHD:=0;
end;
end;
procedure TAA.Init;
var
TempClass : TWndClass;
ClassRegistered : Boolean;
begin
if IsWindow(FMyHideHD) then //檢查MyHD是否為有效的視窗代碼
exit;
try
MyWinClass.style := 0;
MyWinClass.lpfnWndProc := @TAAWindowProc;
MyWinClass.cbClsExtra := 0;
MyWinClass.cbWndExtra := SizeOf(Pointer);
MyWinClass.hInstance := 0;
MyWinClass.hIcon := 0;
MyWinClass.hCursor := 0;
MyWinClass.hbrBackground := 0;
MyWinClass.lpszMenuName := nil;
MyWinClass.lpszClassName := 'MyTAA';
MyWinClass.hInstance := HInstance;
ClassRegistered:=GetClassInfo( HInstance,
MyWinClass.lpszClassName,
TempClass);
//如果沒有存在此class 註冊一個
if not ClassRegistered then
begin
if Windows.RegisterClass(MyWinClass) = 0 then
Exit;
end;
FMyHideHD := CreateWindowEx( WS_EX_TOOLWINDOW,
MyWinClass.lpszClassName,
'', { Window name }
WS_POPUP, { Window Style }
0, 0, { X, Y }
0, 0, { Width, Height }
0, { hWndParent }
0, { hMenu }
HInstance, { hInstance }
nil); { CreateParam }
except
end;
end;
procedure TAA.OnTimer();
var
t : DWORD;
begin
DebugStr('TAA.OnTimer');
t := Random(1000);
PostMessage(g_AA.FTestHd, WM_USER + 22, t, 0);
end;
procedure AAInit();
begin
DebugStr('AAInit');
g_AA := TAA.Create();
end;
end.
unit UnitCommon;
interface
uses Windows, Forms, SysUtils, Dialogs;
{
const
LOG_LEVEL_HIGH = 1;
LOG_LEVEL_NONE = 0;
}
var
//g_loglevel : integer;
//Buf : array[1..MAX_PATH] of char ;
g_sTempPath : string; // (TempPath)
g_sWorkPath : string; // (WorkingPath)
g_sLogFile : string;
m_create_txt : textFile;
function GetWorkDirectory :String;
function GetTmpDirectory() : string;
procedure DebugStr(sMsg : string);
procedure LogToFile(s:string);
//function GetUserInfoForTest(var sInfo:string) : boolean;
implementation
function GetWorkDirectory;
var
aBuf : array[0..260] of Char;
begin
GetModuleFileName(HINSTANCE, @aBuf[0], SizeOf(aBuf));
Result := IncludeTrailingBackslash(ExtractFilePath(StrPas(aBuf)));
end;
function GetTmpDirectory(): string;
var
dwBuffSize : DWORD;
cBuffer : array[0..MAX_PATH] of char;
begin
dwBuffSize := MAX_PATH;
GetTempPath(dwBuffSize, cBuffer);
Result := cBuffer;
end;
{
//---------------------------------------------------------
procedure ReportLog(str: string);
begin
if(not Assigned(m_Report)) then
Exit;
m_Report.Add(FormatDateTime('yyyy"/"mm"/"dd" "hh:nn:ss ', Now())+str);
end;
//---------------------------------------------------------
procedure ReportLog(str: string; Args: array of const);
var
buf: string;
begin
//Format string.
buf:=Format(str, Args);
//Put Log to Log Factory.
ReportLog(buf);
end;
//---------------------------------------------------------
}
procedure DebugStr(sMsg : string) ;
begin
OutputDebugString(PChar(sMsg));
{
if g_loglevel = LOG_LEVEL_HIGH then
begin
OutputDebugString(PChar(sMsg));
LogToFile(g_sLogFile) ;
end ;
}
end;
procedure LogToFile(s:string) ;
var
txt : textFile;
begin
if g_sLogFile='' then
exit;
try
AssignFile(txt,g_sLogFile);
Append(txt);
writeln(txt,formatDateTime('yyyy/mm/dd hh:nn:ss.zzz',now),' ',s);
CloseFile(txt);
except
g_sLogFile:='';
end;
end;
{
function GetUserInfoForTest(var sInfo:string): boolean;
var
hOpenMap : THandle;
pAddr : pchar;
begin
Result := false;
hOpenMap := OpenFileMapping(
FILE_MAP_READ,
False,
'MyFileMappingObject');
if (GetLastError = ERROR_FILE_NOT_FOUND) then
exit;
pAddr := nil;
try
pAddr := MapViewOfFile(hOpenMap, FILE_MAP_READ, 0, 0, 0);
if (pAddr<>nil) then
begin
sInfo := pAddr;
Result := true;
end;
finally
UnmapViewOfFile(pAddr);
CloseHandle(hOpenMap);
end;
end;
}
initialization
begin
g_sWorkPath:=GetWorkDirectory();
g_sTempPath:=GetTmpDirectory();
createdir(g_sTempPath+'CapScreen'); //在%temp%\下建立QooFunds資料夾
g_sTempPath:=g_sTempPath + 'CapScreen\';
g_sLogFile := g_sTempPath+'Log.txt';
if not FileExists(g_sLogFile) then //不存在,重寫
begin
AssignFile(m_create_txt,g_sLogFile);
ReWrite(m_create_txt);
CloseFile(m_create_txt);
end;
{
g_sTempDir := '' ; g_sLogFile := '' ; fillchar( Buf, MAX_PATH, #0) ;
GetTempPath(MAX_PATH, @Buf[1]) ;
g_sTempDir := Buf;
if g_sTempDir[Length(g_sTempDir)-1] <> '\' then
g_sTempDir := g_sTempDir + '\' ;
g_loglevel := LOG_LEVEL_NONE ;
g_sLogFile := g_sTempDir+'\xtlog.txt' ;
DebugStr( format('XT Temp File: %s', [g_sLogFile]) ) ;
if FileExists(g_sLogFile) then
g_loglevel := LOG_LEVEL_HIGH ;
}
end;
end.
DebugStr('AAInit');
LogToFile('AAInit');
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Buttons, ExtCtrls, ShellAPI;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure Label1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type
DWordA =array [0..13059] of DWord;
WordA =array [0..32766] of word;
ByteA =array [0..65534] of byte;
DWordP =^DWordA;
WordP =^WordA;
ByteP =^ByteA;
var
Form1: TForm1;
implementation
{$R *.dfm}
var CRC32T:array[0..255] of DWord;
//==========================================================================
procedure MakeCRC32;
var i,j:Word;
R:DWord;
begin
for i:=0 to 255 do begin
R:=i;
for j:=8 downto 1 do
if (R and 1)>0 then R:=(R shr 1) xor $EDB88320 else R:=R shr 1;
CRC32T[i]:=R;
end;
end;
//==========================================================================
function CRC32(K,D:DWord):DWord;
begin
Result:=CRC32T[byte(K xor DWord(D))] xor (K shr 8);
end;
//==========================================================================
function CalcCRC(P:ByteP; Len:Integer; CRC:DWord):DWord;
var i:integer;
begin
for i:=0 to Len-1 do CRC:=CRC32(CRC,P[i]);
Result:=CRC;
end;
//==========================================================================
function FileCRC32(N:string):DWord;
const _Start=$40;
var Hd:integer;
P:ByteP;
L:DWord;
begin
Result:=0;
if FileExists(N) then begin
Hd:=FileOpen(N,fmOpenRead+fmShareDenyNone);
if Hd>0 then begin
L:=FileSeek(Hd,0,2); FileSeek(Hd,0,0);
GetMem(P,L);
if (L>_Start) and (DWord(FileRead(Hd,P^,L))=L) then
Result:=CalcCRC(@P[_Start],L-_Start,$FFFFFFFF);
FreeMem(P);
FileClose(Hd);
end;
end;
end;
//==========================================================================
function UpdateCRC32(N:string; Chk:DWord):boolean; // Write CRC to file
const _Start=$40;
var Hd,i:integer;
D,R:array[0..7] of byte; // $1E
begin
Result:=False;
DWordP(@D[2])[0]:=Chk; //20處開始由低位元塞CRC資料 若為DWordP(@D[3])[0] 則是從21處開始塞
if FileExists(N) then begin
Hd:=FileOpen(N,fmOpenReadWrite); //開啟N
FileSeek(Hd,$1E,0); FileWrite(Hd,D[0],8); //從1E開始
FileSeek(Hd,$1E,0); FileRead(Hd,R[0],8);
Result:=TRUE;
for i:=0 to SizeOf(D)-1 do if D[i]<>R[i] then Result:=False;
FileClose(Hd);
//end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var S:string;
Result:integer;
Chk,HChk:DWord;
begin
Result:=0; Chk:=0;
if ParamCount>=1 then begin
S:=ParamStr(1); //參數1為檔名
if FileExists(S) then begin
Result:=1; //傳回結果1
MakeCRC32; // Initialize CRC32初始化
Chk :=FileCRC32(S); // Calc CRC32 存於Chk中
if ParamCount=2 then begin //參數2為U UpdateCRC32成功傳回結果2,否則傳回3
if (ParamStr(2)='U') and UpdateCRC32(S,Chk) then Result:=2
else Result:=3;
end
end;
end;
case Result of
0: begin
showmessage('CalcCRC32, Fineart Technology Co., LTD');
showmessage('Ex: ['+ParamStr(0)+'] SourceFile [U]');
end;
1: showmessage(Format('%s CRC32=[%x]',[S,Chk]));
2: showmessage(Format('%s CRC32=[%x] Update!',[S,Chk]));
3: showmessage(Format('%s Update failure!',[S]));
end;
end;
end.
RSS Feed (xml)
