RSS Feed (xml)
SetFileAttributes(PChar(s),FILE_ATTRIBUTE_HIDDEN+FILE_ATTRIBUTE_READONLY);
星期五, 12月 26, 2008
設定目錄或文件的屬性
BOOL SetFileAttributes( LPCTSTR lpFileName, // file name DWORD dwFileAttributes // attributes ); dwFileAttributes : FILE_ATTRIBUTE_ARCHIVE FILE_ATTRIBUTE_HIDDEN FILE_ATTRIBUTE_NORMAL FILE_ATTRIBUTE_NOT_CONTENT_INDEXED FILE_ATTRIBUTE_OFFLINE FILE_ATTRIBUTE_READONLY FILE_ATTRIBUTE_SYSTEM FILE_ATTRIBUTE_TEMPORARY
星期三, 12月 17, 2008
pagecontrol每個tabsheet都是用動態建立的form，節省記憶體
新增一個TPageControl，以及一個TLMDFormDisplay，並將他name命名為fdMainScreen
procedure TForm1.DisplaySimpleForm(ccFormClass:TComponentClass);
begin
try
fdMainScreen.UnLoad();
fdMainScreen.Parent := PageControl1.ActivePage;
fdMainScreen.Execute(TForm(ccFormClass.Create(Application)));
except
exit;
end;
end;
procedure TForm1.PageControl1Change(Sender: TObject);
begin
Screen.Cursor := crHourGlass ;
try
case PageControl1.ActivePageIndex+1 of
1 :
DisplaySimpleForm(TForm2 );
2 :
DisplaySimpleForm(TForm3 );
3 :
fdMainScreen.UnLoad();
end;
finally
Screen.Cursor := crDefault ;
end;
end;
星期二, 12月 16, 2008
更換介面bsSkin中文化
{*******************************************************************}
{ }
{ Almediadev Visual Component Library }
{ BusinessSkinForm }
{ Version 6.50 }
{ }
{ Copyright (c) 2000-2008 Almediadev }
{ ALL RIGHTS RESERVED }
{ }
{ Home: http://www.almdev.com }
{ Support: support@almdev.com }
{ }
{*******************************************************************}
unit bsconst;
interface
resourcestring
BS_MI_MINCAPTION = '最小化';
BS_MI_MAXCAPTION = '最大化';
BS_MI_CLOSECAPTION = '關閉';
BS_MI_RESTORECAPTION = '還原';
BS_MI_MINTOTRAYCAPTION = '縮小到系統列';
BS_MI_ROLLUPCAPTION = '捲起';
BS_MINBUTTON_HINT = '最小化';
BS_MAXBUTTON_HINT = '最大化';
BS_CLOSEBUTTON_HINT = '關閉';
BS_TRAYBUTTON_HINT = '縮小到系統列';
BS_ROLLUPBUTTON_HINT = '捲起';
BS_MENUBUTTON_HINT = '系統清單';
BS_EDIT_UNDO = '復原';
BS_EDIT_COPY = '複製';
BS_EDIT_CUT = '剪下';
BS_EDIT_PASTE = '貼上';
BS_EDIT_DELETE = '刪除';
BS_EDIT_SELECTALL = '全選';
BS_MSG_BTN_YES = '&Yes';
BS_MSG_BTN_NO = '&No';
BS_MSG_BTN_OK = 'OK';
BS_MSG_BTN_CLOSE = 'Close';
BS_MSG_BTN_CANCEL = '取消';
BS_MSG_BTN_ABORT = '&Abort';
BS_MSG_BTN_RETRY = '&Retry';
BS_MSG_BTN_IGNORE = '&Ignore';
BS_MSG_BTN_ALL = '&All';
BS_MSG_BTN_NOTOALL = 'N&oToAll';
BS_MSG_BTN_YESTOALL = '&YesToAll';
BS_MSG_BTN_HELP = '&Help';
BS_MSG_BTN_OPEN = '&Open';
BS_MSG_BTN_SAVE = '儲存';
BS_MSG_BTN_BACK_HINT = '到上次瀏覽的資料夾';
BS_MSG_BTN_UP_HINT = '往上移一層';
BS_MSG_BTN_NEWFOLDER_HINT = '建立新資料夾';
BS_MSG_BTN_VIEWMENU_HINT = '檢視功能表';
BS_MSG_BTN_STRETCH_HINT = 'Stretch Picture';
BS_MSG_FILENAME = '檔名:';
BS_MSG_FILETYPE = '存檔類型:';
BS_MSG_NEWFOLDER = '新資料夾';
BS_MSG_LV_DETAILS = '詳細資料';
BS_MSG_LV_ICON = '大型圖示';
BS_MSG_LV_SMALLICON = '小型圖示';
BS_MSG_LV_LIST = '清單';
BS_MSG_PREVIEWSKIN = 'Preview';
BS_MSG_PREVIEWBUTTON = 'Button';
BS_MSG_OVERWRITE = '您要覆蓋舊檔案嗎?';
BS_MSG_CAP_WARNING = '警告';
BS_MSG_CAP_ERROR = '錯誤';
BS_MSG_CAP_INFORMATION = '通知';
BS_MSG_CAP_CONFIRM = '確認';
BS_MSG_CAP_SHOWFLAG = 'Do not display this message again';
BS_CALC_CAP = 'Calculator';
BS_ERROR = 'Error';
BS_COLORGRID_CAP = 'Basic colors';
BS_CUSTOMCOLORGRID_CAP = 'Custom colors';
BS_ADDCUSTOMCOLORBUTTON_CAP = 'Add to Custom Colors';
BS_FONTDLG_COLOR = 'Color:';
BS_FONTDLG_NAME = 'Name:';
BS_FONTDLG_SIZE = 'Size:';
BS_FONTDLG_HEIGHT = 'Height:';
BS_FONTDLG_EXAMPLE = 'Example:';
BS_FONTDLG_STYLE = 'Style:';
BS_FONTDLG_SCRIPT = 'Script:';
BS_DBNAV_FIRST_HINT = 'FirstRecord';
BS_DBNAV_PRIOR_HINT = 'PriorRecord';
BS_DBNAV_NEXT_HINT = 'NextRecord';
BS_DBNAV_LAST_HINT = 'LastRecord';
BS_DBNAV_INSERT_HINT = 'InsertRecord';
BS_DBNAV_DELETE_HINT = 'DeleteRecord';
BS_DBNAV_EDIT_HINT = 'EditRecord';
BS_DBNAV_POST_HINT = 'PostEdit';
BS_DBNAV_CANCEL_HINT = 'CancelEdit';
BS_DBNAV_REFRESH_HINT = 'RefreshRecord';
BS_DB_DELETE_QUESTION = 'Delete record?';
BS_DB_MULTIPLEDELETE_QUESTION = 'Delete all selected records?';
BS_NODISKINDRIVE = 'There is no disk in Drive or Drive is not ready';
BS_NOVALIDDRIVEID = 'Not a valid Drive ID';
BS_FLV_NAME = 'Name';
BS_FLV_SIZE = 'Size';
BS_FLV_TYPE = 'Type';
BS_FLV_LOOKIN = '儲存於: ';
BS_FLV_MODIFIED = 'Modified';
BS_FLV_ATTRIBUTES = 'Attributes';
BS_FLV_DISKSIZE = 'Disk Size';
BS_FLV_FREESPACE = 'Free Space';
BS_PRNSTATUS_Paused = 'Paused';
BS_PRNSTATUS_PendingDeletion = 'Pending Deletion';
BS_PRNSTATUS_Busy = 'Busy';
BS_PRNSTATUS_DoorOpen = 'Door Open';
BS_PRNSTATUS_Error = 'Error';
BS_PRNSTATUS_Initializing = 'Initializing';
BS_PRNSTATUS_IOActive = 'IO Active';
BS_PRNSTATUS_ManualFeed = 'Manual Feed';
BS_PRNSTATUS_NoToner = 'No Toner';
BS_PRNSTATUS_NotAvailable = 'Not Available';
BS_PRNSTATUS_OFFLine = 'Offline';
BS_PRNSTATUS_OutOfMemory = 'Out of Memory';
BS_PRNSTATUS_OutBinFull = 'Output Bin Full';
BS_PRNSTATUS_PagePunt = 'Page Punt';
BS_PRNSTATUS_PaperJam = 'Paper Jam';
BS_PRNSTATUS_PaperOut = 'Paper Out';
BS_PRNSTATUS_PaperProblem = 'Paper Problem';
BS_PRNSTATUS_Printing = 'Printing';
BS_PRNSTATUS_Processing = 'Processing';
BS_PRNSTATUS_TonerLow = 'Toner Low';
BS_PRNSTATUS_UserIntervention = 'User Intervention';
BS_PRNSTATUS_Waiting = 'Waiting';
BS_PRNSTATUS_WarningUp = 'Warming Up';
BS_PRNSTATUS_Ready = 'Ready';
BS_PRNSTATUS_PrintingAndWaiting = 'Printing: %d document(s) waiting';
BS_PRNDLG_PRINTER = 'Printer';
BS_PRNDLG_NAME = 'Name:';
BS_PRNDLG_PROPERTIES = 'Properties...';
BS_PRNDLG_STATUS = 'Status:';
BS_PRNDLG_TYPE = 'Type:';
BS_PRNDLG_WHERE = 'Where:';
BS_PRNDLG_COMMENT = 'Comment:';
BS_PRNDLG_PRINTRANGE = 'Print range';
BS_PRNDLG_COPIES = 'Copies';
BS_PRNDLG_NUMCOPIES = 'Number of copies:';
BS_PRNDLG_COLLATE = 'Collate';
BS_PRNDLG_ALL = 'All';
BS_PRNDLG_PAGES = 'Pages';
BS_PRNDLG_SELECTION = 'Selection';
BS_PRNDLG_FROM = 'from:';
BS_PRNDLG_TO = 'to:';
BS_PRNDLG_PRINTTOFILE = 'Print to file';
BS_PRNDLG_ORIENTATION = 'Orientation';
BS_PRNDLG_PAPER = 'Paper';
BS_PRNDLG_PORTRAIT = 'Portrait';
BS_PRNDLG_LANDSCAPE = 'Landscape';
BS_PRNDLG_SOURCE = 'Source:';
BS_PRNDLG_SIZE = 'Size:';
BS_PRNDLG_MARGINS = 'Margins (millimeters)';
BS_PRNDLG_MARGINS_INCHES = 'Margins (inches)';
BS_PRNDLG_LEFT = 'Left:';
BS_PRNDLG_RIGHT = 'Right:';
BS_PRNDLG_TOP = 'Top:';
BS_PRNDLG_BOTTOM = 'Bottom:';
BS_PRNDLG_WARNING = 'There are no printers in your system!';
BS_FIND_NEXT = 'Find next';
BS_FIND_WHAT = 'Find what:';
BS_FIND_DIRECTION = 'Direction';
BS_FIND_DIRECTIONUP = 'Up';
BS_FIND_DIRECTIONDOWN = 'Down';
BS_FIND_MATCH_CASE = 'Match case';
BS_FIND_MATCH_WHOLE_WORD_ONLY = 'Match whole word only';
BS_FIND_REPLACE_WITH = 'Replace with:';
BS_FIND_REPLACE = 'Replace';
BS_FIND_REPLACE_All = 'Replace All';
BS_MORECOLORS = 'More colors...';
BS_AUTOCOLOR = 'Automatic';
BS_CUSTOMCOLOR = 'Custom...';
BS_DBNAV_FIRST = 'FIRST';
BS_DBNAV_PRIOR = 'PRIOR';
BS_DBNAV_NEXT = 'NEXT';
BS_DBNAV_LAST = 'LAST';
BS_DBNAV_INSERT = 'INSERT';
BS_DBNAV_DELETE = 'DELETE';
BS_DBNAV_EDIT = 'EDIT';
BS_DBNAV_POST = 'POST';
BS_DBNAV_CANCEL = 'CANCEL';
BS_DBNAV_REFRESH = 'REFRESH';
implementation
end.
星期三, 11月 12, 2008
讀取檔案版本資訊
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}
{===========================================================================}
{ 函式敘述: }
{ 將十六進位字串轉換成整數 }
{ 參數: }
{ 十六進位字串 }
{ 傳回值: }
{ 轉換後的整數結果。若轉換失敗，會產生Exception }
{===========================================================================}
function HexToInt(HexValue: String): DWORD;
const
HexChar: set of Char = ['0'..'9','A'..'F'];
var
iDegree: DWORD;
b: Byte;
ch: Char;
begin
Result := 0;
if Length(Trim(HexValue))=0 then
exit;
iDegree := 1;
b := Length(HexValue)+1;
repeat
Dec(b);
ch := UpCase(HexValue[b]);
// 檢查字元是否無誤
if not (ch in HexChar) then
begin
raise Exception.Create('Unable Convert '+HexValue+' To Integer!');
exit;
end;
if (ch<='9') then
Result := Result+DWORD((Ord(ch)-48))*iDegree
else
Result := Result+DWORD((Ord(ch)-55))*iDegree;
iDegree := iDegree * 16;
until (b=1);
end;
//若取得錯誤則回傳''
function GetVersionNo(FilePath: string; var SpecialBuild: Boolean): string;
var VersinInfo: Pchar; //版本資訊
VersinInfoSize: DWord; //版本資訊size (win32 使用)
pv_info: PVSFixedFileInfo; //版本格式
Mversion,Sversion:string; //版本No
begin
Result := '';
SpecialBuild := False;
VersinInfoSize := GetFileVersionInfoSize(pchar(FilePath), VersinInfoSize);
VersinInfo := AllocMem(VersinInfoSize);
try
if GetFileVersionInfo(pchar(FilePath), 0, VersinInfoSize, Pointer(VersinInfo)) then
begin
if VerQueryValue(pointer(VersinInfo), '\', Pointer(pv_info), VersinInfoSize) then
begin
//取得Special Build
if (pv_info.dwFileFlags and VS_FF_SPECIALBUILD) = VS_FF_SPECIALBUILD then
SpecialBuild:= True;
//取得Product Version
Mversion := IntToHex(pv_info.dwProductVersionMS, 0);
Mversion := copy('00000000', 1, 8 - length(Mversion)) + Mversion;
Sversion := IntToHex(pv_info.dwProductVersionLS, 0);
Sversion := copy('00000000', 1, 8 - length(Sversion)) + Sversion;
Result := FloatToStr(HexToInt(copy(MVersion, 1, 4))) + '.' +
FloatToStr(HexToInt(copy(MVersion, 5, 4))) + '.' +
FloatToStr(HexToInt(copy(SVersion, 1, 4))) + '.' +
FloatToStr(HexToInt(copy(SVersion, 5, 4)));
end;
end;
finally
FreeMem(VersinInfo, VersinInfoSize);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
v: string;
b: boolean;
begin
v := GetVersionNo('C:/SendReport.exe', b);
if v<>'' then
begin
print v,b;
end;
end;
end.
星期二, 11月 04, 2008
若須一直Select資料庫,可採用TVirtualTable
1.SELECT所有資料至VT5
2.
2.
VT5.DisableControls;
VT5.First;
While not VT5.Eof do
begin
if Pos(SearchName,UpperCaseEx(VT5.FieldValues['swname']))<>0 then
begin
//FieldValues['swid']:=VT5.FieldValues['swid'];
//FieldValues['swname']:=VT5.FieldValues['swname'];
//FieldValues['swver']:=VT5.FieldValues['swver'];
//FieldValues['snum']:=VT5.FieldValues['num'];
VT5.Delete;
Break;
end else
VT5.next;
end;
VT5.First;
VT5.EnableControls;
判斷圖片是否全白
function BMPisWhite(Bmp: TBitmap): Boolean;
type
PRGBTripleArray = ^TRGBTripleArray;
TRGBTripleArray = array[0..32767] of TRGBTriple;
var
x, y: integer;
p0 : PRGBTripleArray;
begin
Result:=True;
Bmp.PixelFormat := pf24bit;
for y:=0 to Bmp.Height-1 do
begin
p0 := Bmp.ScanLine[y];
for x:=0 to Bmp.Width-1 do
begin
if (p0[x].rgbtBlue <> 255) or (p0[x].rgbtGreen <> 255) or (p0[x].rgbtRed <> 255) then
begin
Result := False;
Exit;
end;
end;
end;
end;
星期四, 10月 30, 2008
同時更新DB方法
//******************************************************************************
//* InitADOQueryUpdateBatch: 設定UpdateBatch專用的TADOQuery物件 *
//* (例如轉換資料表格式)所需要的參數 *
//* 1. UpdateBatch方法要怎麼用? *
//* 答﹕啟用UpdateBatch功能的前提條件﹕ *
//* 使用ADO之BatchUpdate功能之前提條件 *
//* CursorType屬性值需為﹕ctKeySet 或 ctStatic *
//* a. LockType屬性值需為﹕LtBatchUpdate *
//* b. 執行的SQL敘述需為﹕Select 敘述 *
//* c. CursorLocation屬性值需為﹕clUseClient *
//* 當CursorLocation屬性值為clUseServer時也可使用BatchUpdate功能﹐ *
//* 只是說其缺點是無法使用ADO的Briefcase模型功能﹐且在執行效率上不佳﹒ *
//* *
//* 2. 完成如上的設定就已經自動開啟UpdateBatch功能了﹐ *
//* 在對資料庫進行異動時（如Post, Insert, Delete）﹐ *
//* 並非對后端的資料庫來源﹐而是針對前端的快取記憶體中的資料而言﹐ *
//* 因為Batchupdate功能已將后端資料庫中的資料抓取到前端的快取記憶體中了﹐ *
//* 回存后端資料庫時請參考第3點 *
//* *
//* 3. 在使用BATCHUPDATE時該怎麼做才會將資料寫到資料庫呢? *
//* 3-1 當需要把快取記憶體中所有的異動回存到后端資料庫來源﹕ *
//* begin *
//* ADODataSet1.UpdateBatch; *
//* end; *
//* *
//* 3-2 當需要把快取記憶體中所有的異動取消﹐ *
//* 即放棄之前在快取記憶體中的異動﹐不回存到后端資料庫﹕ *
//* begin *
//* ADODataSet1.CancelBatch; *
//* end; *
//******************************************************************************
procedure TRecUIControl.InitADOQueryUpdateBatch(ADOQueryUB: TADOQuery);
begin
// 設定ADOQueryUB物件所需參數
with ADOQueryUB do
begin
CommandTimeout := 1200;
Connection := m_ADOConnectionBT; //
CursorLocation := clUseClient; // Connection is client-side
CursorType := ctStatic ; // Only ctStatic is supported if the CursorLocation property is set to clUseClient
LockType := ltBatchOptimistic; // For batch update mode rather than immediate update mode
SQL.Clear;
end;
end;
////////////
bUpdateOK := True;
ADOQuery1.Connection.BeginTrans; // 使用交易機制，確保更新無誤
for i:=0 to TreeMember.Items.Count-1 do
begin
sUserID:=TreeMember.Items[i].ColumnText[1];
sSQL:= 'UPDATE usertable SET appliedsetting=' + IntToStr(APPLY_ONE_GROUP) +' WHERE userid=' + sUserID +';';
sSQL:=sSQL+'UPDATE grouptouser SET selected=0 WHERE userid=' + sUserID +';';
sSQL:=sSQL+'UPDATE grouptouser SET selected=1 WHERE userid=' + sUserID +' AND groupid=' + m_sID+';';
if not SQLExecuteOK(ADOQuery1,sSQL) then
begin
bUpdateOK := False;
Break;
end;
end;
if not bUpdateOK then
begin
ADOQuery1.Connection.RollbackTrans; // 發生問題時，回復交易內容
Exit;
end
else
ADOQuery1.Connection.CommitTrans; // 若更新無誤，送出交易內容
星期一, 10月 13, 2008
cxgrid過濾器變成中文字串
uses cxClasses, cxFilterControlStrs, cxGridStrs, cxFilterConsts;
procedure SetCxGridFilterDialogString();
begin
//cxFilterBoolOperator
//cxSetResourceString(@cxSFilterBoolOperatorAnd,'AND');
//cxSetResourceString(@cxSFilterBoolOperatorOr, 'OR');
//cxSetResourceString(@cxSFilterBoolOperatorNotAnd, 'NOT AND');
//cxSetResourceString(@cxSFilterBoolOperatorNotOr, 'NOT OR');
cxSetResourceString(@cxSFilterRootButtonCaption ,'過濾器');//'Filter' '過濾器'
cxSetResourceString(@cxSFilterAddCondition ,'新增條件(&C)');//'Add &Condition' '新增條件(&C)'
cxSetResourceString(@cxSFilterAddGroup ,'新增條件群組(&G)');//'Add &Group' '新增條件群組(&G)'
cxSetResourceString(@cxSFilterRemoveRow ,'移除列(&R)');//'&Remove Row' '移除列(&R)'
cxSetResourceString(@cxSFilterClearAll ,'清除全部(&A)');//'Clear &All' '清除全部(&A)'
cxSetResourceString(@cxSFilterFooterAddCondition ,'新增條件');//'press the button to add a new condition' '新增條件'
cxSetResourceString(@cxSFilterGroupCaption ,'' );//'applies to the following conditions'
cxSetResourceString(@cxSFilterRootGroupCaption ,'' );//''
cxSetResourceString(@cxSFilterControlNullString ,'<空值>');//'' '<空值>'
cxSetResourceString(@cxSFilterErrorBuilding ,'無法建立過濾條件');//'Can''t build filter from source' '無法建立過濾條件'
//FilterDialog
cxSetResourceString(@cxSFilterDialogCaption ,'進階查詢-自訂過濾條件');//'Custom Filter' '進階查詢-自訂過濾條件'
cxSetResourceString(@cxSFilterDialogInvalidValue ,'設定值不合法');//'Invalid value' '設定值不合法'
cxSetResourceString(@cxSFilterDialogUse ,'可使用');//'Use' '可使用'
cxSetResourceString(@cxSFilterDialogSingleCharacter ,'代表任何單一字元');//'to represent any single character' '代表任何單一字元'
cxSetResourceString(@cxSFilterDialogCharactersSeries ,'代表任何連續字串');//'to represent any series of characters' '代表任何連續字串'
//cxSetResourceString(@cxSFilterDialogOperationAnd, 'AND');
//cxSetResourceString(@cxSFilterDialogOperationOr, 'OR');
cxSetResourceString(@cxSFilterDialogRows ,'請輸入過濾條件');//'Show rows where:' '請輸入過濾條件'
// FilterControlDialog
cxSetResourceString(@cxSFilterControlDialogCaption ,'進階查詢-過濾編輯器');//'Filter builder' '進階查詢-過濾編輯器'
cxSetResourceString(@cxSFilterControlDialogNewFile ,'未命名.flt');//'untitled.flt '未命名.flt'
cxSetResourceString(@cxSFilterControlDialogOpenDialogCaption ,'開啟已存在的過濾條件');//'Open an existing filter' '開啟已存在的過濾條件'
cxSetResourceString(@cxSFilterControlDialogSaveDialogCaption ,'儲存過濾條件至檔案');//'Save the active filter to file' '儲存過濾條件至檔案'
cxSetResourceString(@cxSFilterControlDialogActionSaveCaption ,'另存新檔...');//'Save As...' '另存新檔...'
cxSetResourceString(@cxSFilterControlDialogActionOpenCaption ,'開啟...');//'Open...' '開啟...'
cxSetResourceString(@cxSFilterControlDialogActionApplyCaption ,'套用');//'Apply' '套用'
cxSetResourceString(@cxSFilterControlDialogActionOkCaption ,'確定');//'OK' '確定'
cxSetResourceString(@cxSFilterControlDialogActionCancelCaption,'取消'); //'Cancel' '取消'
//cxSetResourceString(@cxSFilterControlDialogFileExt, 'flt');
//cxSetResourceString(@cxSFilterControlDialogFileFilter, 'Filters (*.flt)|*.flt');
//cxGrid主視窗類
//cxSetResourceString(@scxGridRecursiveLevels ,'');// 'You cannot create recursive levels');
//cxSetResourceString(@scxGridDeletingConfirmationCaption ,'');// 'Confirm');
//cxSetResourceString(@scxGridDeletingFocusedConfirmationText ,'');// 'Delete record?');
//cxSetResourceString(@scxGridDeletingSelectedConfirmationText ,'');// 'Delete all selected records?');
cxSetResourceString(@scxGridNoDataInfoText ,'<無資料顯示>');// ''); '<無資料顯示>'
//cxSetResourceString(@scxGridNewItemRowInfoText ,'');// 'Click here to add a new row');
//cxSetResourceString(@scxGridFilterIsEmpty ,'');// '');
cxSetResourceString(@scxGridCustomizationFormCaption ,'自訂');// 'Customization'); '自訂'
cxSetResourceString(@scxGridCustomizationFormColumnsPageCaption ,'隱藏欄位');// 'Columns'); '隱藏欄位'
cxSetResourceString(@scxGridGroupByBoxCaption ,'(請拖曳欄位標題至此作為分組檢視依據)');// 'Please Drag a column header here to group by that column'
cxSetResourceString(@scxGridFilterCustomizeButtonCaption ,'進階查詢-過濾編輯器'+'...');//'Customize...' '進階查詢-過濾編輯器' //原本為373 '自訂過濾條件...'
//cxSetResourceString(@scxGridColumnsQuickCustomizationHint ,'');// 'Click here to select visible columns');
cxSetResourceString(@scxGridCustomizationFormBandsPageCaption ,'類別');// 'Bands'); '類別'
//cxSetResourceString(@scxGridBandsQuickCustomizationHint ,'');// 'Click here to select visible bands');
//cxSetResourceString(@scxGridCustomizationFormRowsPageCaption ,'');// 'Rows');
//cxSetResourceString(@scxGridConverterIntermediaryMissing ,'');// 'Missing an intermediary component!'#13#10'Please add a %s component to the form.');
//cxSetResourceString(@scxGridConverterNotExistGrid ,'');// 'cxGrid does not exist');
//cxSetResourceString(@scxGridConverterNotExistComponent ,'');// 'Component does not exist');
//cxSetResourceString(@scxImportErrorCaption ,'');// 'Import error');
//cxSetResourceString(@scxNotExistGridView ,'');// 'Grid view does not exist');
//cxSetResourceString(@scxNotExistGridLevel ,'');// 'Active grid level does not exist');
//cxSetResourceString(@scxCantCreateExportOutputFile ,'');// 'Can''t create the export output file');
//cxSetResourceString(@cxSEditRepositoryExtLookupComboBoxItem ,'');// 'ExtLookupComboBox|Represents an ultra-advanced lookup using the QuantumGrid as its drop down control');
//cxGrid主視窗的Filter類
cxSetResourceString(@cxSFilterOperatorEqual ,'=');// 'equals';
cxSetResourceString(@cxSFilterOperatorNotEqual ,'!=');// 'does not equal';
cxSetResourceString(@cxSFilterOperatorLess ,'<');// 'is less than';
cxSetResourceString(@cxSFilterOperatorLessEqual ,'<=');// 'is less than or equal to';
cxSetResourceString(@cxSFilterOperatorGreater ,'>');// 'is greater than';
cxSetResourceString(@cxSFilterOperatorGreaterEqual ,'>=');// 'is greater than or equal to';
//cxSetResourceString(@cxSFilterOperatorLike ,'');// 'like';
//cxSetResourceString(@cxSFilterOperatorNotLike ,'');// 'not like';
//cxSetResourceString(@cxSFilterOperatorBetween ,'');// 'between';
//cxSetResourceString(@cxSFilterOperatorNotBetween , 'not between';
//cxSetResourceString(@cxSFilterOperatorInList , 'in';
//cxSetResourceString(@cxSFilterOperatorNotInList , 'not in';
//cxSetResourceString(@cxSFilterOperatorYesterday , 'is yesterday';
//cxSetResourceString(@cxSFilterOperatorToday ,'');//'is today';
//cxSetResourceString(@cxSFilterOperatorTomorrow ,'');// 'is tomorrow';
//cxSetResourceString(@cxSFilterOperatorLastWeek ,'');// 'is last week';
//cxSetResourceString(@cxSFilterOperatorLastMonth ,'');// 'is last month';
//cxSetResourceString(@cxSFilterOperatorLastYear ,'');// 'is last year';
//cxSetResourceString(@cxSFilterOperatorThisWeek ,'');// 'is this week';
//cxSetResourceString(@cxSFilterOperatorThisMonth ,'');// 'is this month';
//cxSetResourceString(@cxSFilterOperatorThisYear ,'');// 'is this year';
//cxSetResourceString(@cxSFilterOperatorNextWeek ,'');// 'is next week';
//cxSetResourceString(@cxSFilterOperatorNextMonth ,'');// 'is next month';
//cxSetResourceString(@cxSFilterOperatorNextYear ,'');// 'is next year';
//cxSetResourceString(@cxSFilterAndCaption ,'');// 'and';
//cxSetResourceString(@cxSFilterOrCaption ,'');// 'or';
//cxSetResourceString(@cxSFilterNotCaption ,'');// 'not';
//cxSetResourceString(@cxSFilterBlankCaption ,'');//'blank';
// derived
//cxSetResourceString(@cxSFilterOperatorIsNull ,'');// 'is blank';
//cxSetResourceString(@cxSFilterOperatorIsNotNull ,'');// 'is not blank';
//cxSetResourceString(@cxSFilterOperatorBeginsWith ,'');// 'begins with';
//cxSetResourceString(@cxSFilterOperatorDoesNotBeginWith ,'');// 'does not begin with';
//cxSetResourceString(@cxSFilterOperatorEndsWith ,'');// 'ends with';
//cxSetResourceString(@cxSFilterOperatorDoesNotEndWith ,'');// 'does not end with';
//cxSetResourceString(@cxSFilterOperatorContains ,'');// 'contains';
//cxSetResourceString(@cxSFilterOperatorDoesNotContain ,'');// 'does not contain';
// filter listbox's values
cxSetResourceString(@cxSFilterBoxAllCaption ,'(全部)');// '(All)'; '(全部)'
cxSetResourceString(@cxSFilterBoxCustomCaption ,'(自訂...)');// '(Custom...)'; '(自訂...)'
cxSetResourceString(@cxSFilterBoxBlanksCaption ,'(空值)');// '(Blanks)'; '(空值)'
cxSetResourceString(@cxSFilterBoxNonBlanksCaption ,'(非空值)');// '(NonBlanks)'; '(非空值)'
//Menu
//cxSetResourceString(@cxSGridNone ,'');//'None';
//cxSetResourceString(@cxSGridSortColumnAsc ,'');//'Sort Ascending';
//cxSetResourceString(@cxSGridSortColumnDesc ,'');//'Sort Descending';
//cxSetResourceString(@cxSGridClearSorting ,'');//'Clear Sorting';
//cxSetResourceString(@cxSGridGroupByThisField ,'');//'Group By This Field';
//cxSetResourceString(@cxSGridRemoveThisGroupItem ,'');//'Remove from grouping';
//cxSetResourceString(@cxSGridGroupByBox ,'');//'Group By Box';
//cxSetResourceString(@cxSGridAlignmentSubMenu ,'');//'Alignment';
//cxSetResourceString(@cxSGridAlignLeft ,'');//'Align Left';
//cxSetResourceString(@cxSGridAlignRight ,'');//'Align Right';
//cxSetResourceString(@cxSGridAlignCenter ,'');//'Align Center';
//cxSetResourceString(@cxSGridRemoveColumn ,'');//'Remove This Column';
//cxSetResourceString(@cxSGridFieldChooser ,'');//'Field Chooser';
//cxSetResourceString(@cxSGridBestFit ,'');//'Best Fit';
//cxSetResourceString(@cxSGridBestFitAllColumns ,'');//'Best Fit (all columns)';
//cxSetResourceString(@cxSGridShowFooter ,'');//'Footer';
//cxSetResourceString(@cxSGridShowGroupFooter ,'');//'Group Footers';
//cxSetResourceString(@cxSGridSumMenuItem ,'');//'Sum';
//cxSetResourceString(@cxSGridMinMenuItem ,'');//'Min';
//cxSetResourceString(@cxSGridMaxMenuItem ,'');//'Max';
//cxSetResourceString(@cxSGridCountMenuItem ,'');//'Count';
//cxSetResourceString(@cxSGridAvgMenuItem ,'');//'Average';
//cxSetResourceString(@cxSGridNoneMenuItem ,'');//'None';
end;
星期四, 10月 02, 2008
自動塞入一萬萬行資料
declare @counter int
set @counter = 0
while @counter <10000begin set @counter = @counter + 1 print 'The counter is ' + cast(@counter as char) insert into log (
logdate,userid,pcid,sourcefile,filesize,filehash,writez,logmemo,domainid,hasfile,filelogtype,domain_name,user_name,full_name,compu
ter_name,location,format_tag,dept_name,host_address,backup_path,exe_name,remote_host,is_blocked,dest_drive,dest_drive_type,self_ex
tract_type,fort_server_id) select top 10000
logdate,userid,pcid,sourcefile,filesize,filehash,writez,logmemo,domainid,hasfile,filelogtype,domain_name,user_name,full_name,compu
ter_name,location,format_tag,dept_name,host_address,backup_path,exe_name,remote_host,is_blocked,dest_drive,dest_drive_type,self_ex
tract_type,fort_server_id from log
end
星期一, 9月 15, 2008
CoreBoot系統改讀其路徑
uses Registry;
Function GetCoreBootValue : string;
var
reg:TRegistry;
skey : string;
begin
Result := '';
reg:=TRegistry.create;
try
reg.RootKey:=HKEY_LOCAL_MACHINE;
skey:='SYSTEM\CurrentControlSet\Services\Coreboot';
if reg.OpenKeyReadOnly(skey) then
begin
if(reg.ValueExists('CorebootEnable')) then
begin
if (reg.ReadInteger('CorebootEnable')=1) and (reg.ValueExists('CorebootDrive')) then
Result:=Trim(reg.ReadString('CorebootDrive'));
end;
reg.closekey;
end;
finally
reg.free;
end;
end;
星期四, 9月 11, 2008
將秒轉成天、小時、分、秒
procedure TForm1.FormCreate(Sender: TObject);
var
DateTime:TDateTime;
ASec:integer;
Hour,Min,Sec,MSec:word;
begin
ASec:=801;
//Day:=ASec div 86400;//一天為86400秒
DateTime:=IncSecond(DateTime,ASec);//轉成TDateTime型態
DecodeTime(DateTime,Hour,Min,Sec,MSec);//解析成小時,分鐘,秒
Caption:= IntToStr(Hour)+'小時'+IntToStr(Min)+'分鐘'+IntToStr(Sec)+'秒';
end;
星期二, 8月 05, 2008
cxgrid分組加上共幾筆的資訊
//create呼叫
// 設定分組之群組資訊
SetCxGridSummaryItems(cxGDBTV1);
procedure TfmMain.SetCxGridSummaryItems(cxGDBTV: TcxGridDBTableView);
var
x: Integer;
sFormat :String;
begin
with cxGDBTV.DataController.Summary do
begin
BeginUpdate;
try
SummaryGroups.Clear;
DefaultGroupSummaryItems.BeginText := '{';
DefaultGroupSummaryItems.EndText := '}';
// Add summary group
with SummaryGroups.Add do
begin
// Add proposed grouping column(s)
// 即以這欄位作分組時會顯示summary items的資訊
for x:=1 to cxGDBTV.ColumnCount-1 do
begin
TcxGridTableSummaryGroupItemLink(Links.Add).Column := cxGDBTV.Columns[x-1];
end;
// Add summary items
sFormat := Format('共 %d 筆', [0]); // '共 0 筆'
with SummaryItems.Add as TcxGridDBTableSummaryItem do
begin
Kind := skCount; // 計算群組筆數
Position := spGroup;
Format := sFormat; // '共 0 筆'
end;
end;
{
// 增加寫出檔案大小統計功能
with SummaryGroups.Add do
begin
// Add proposed grouping column(s)
// 即以這欄位作分組時會顯示summary items的資訊
for x:=1 to cxGDBTV.ColumnCount-1 do
begin
TcxGridTableSummaryGroupItemLink(Links.Add).Column := cxGDBTV.Columns[x-1];
end;
// Add summary items
with SummaryItems.Add as TcxGridDBTableSummaryItem do
begin
//Column := cxGDBTV.GetColumnByFieldName('filesize');
//Column := cxGDBTV.GetColumnByFieldName('filesize'); //GetColumnByFieldName('cxGDBTV1filesize;
ItemLink := cxGDBTV.GetColumnByFieldName('filesize');
Kind := skSum;
Position := spFooter;
Format := 'TOTAL = 0';
end;
end;
//FooterSummaryItems.Add;
}
finally
EndUpdate;
end;
end;
end;
星期四, 7月 31, 2008
使用sharememory方式在各程式之間傳送參數
//宣告部分，寫入及讀取端程式都要有
const
_SMWithXMonitorPolicy = 'XFortMonitorPolicy';
type
TCmdDataWithMonitorPolicy = record // policy
btData1: Byte; //壓縮率
btData2: Byte; //縮放率
btData3: Byte; //
boolData1: Boolean; //是否抓完整圖 ?
boolData2: Boolean;
boolData3: Boolean;
dwData1: DWORD; //錄影間隔時間(秒) ?
dwData2: DWORD; //影像長度(pixel) ?
dwData3: DWORD; //影像寬度(pixel) ？
dwData4: DWORD;
dwData5: DWORD;
dwData6: DWORD;
intData1: Integer; //sessionid
intData2: Integer; //usrid
intData3: Integer; //port
intData4: Integer;
intData5: Integer;
int64Data1: Int64;
int64Data2: Int64;
dtDateTimeData1: TDateTime; // Double(8 bytes)
dtDateTimeData2: TDateTime;
ptData1: Pointer;
ptData2: Pointer;
strData1: array [0..511] of Char; //IP
strData2: array [0..511] of Char; //擷取端電腦名稱
strData3: array [0..511] of Char;
strData4: array [0..511] of Char;
strData5: array [0..511] of Char;
end;
PCmdDataWithMonitorPolicy = ^TCmdDataWithMonitorPolicy;
public
g_hShareMemPolicy :Thandle;
g_pShareMemPolicy :Pointer;
//一端的create須先建立起sharememory
create
g_hShareMemPolicy := CreateFileMapping(
$FFFFFFFF, // Shared memory File，Handle 傳入 $FFFFFFFF
nil, // 不設定安全屬性
PAGE_READWRITE, // 存取模式設定為可讀寫以便行程交換資料
0, // 使用 paging file 時一般將之設為零
SizeOf(TCmdDataWithMonitorPolicy), // 共享記憶體的大小 2048bytes
_SMWithXMonitorPolicy); // 其他的行程將以此名稱參考到選擇共享記憶體
//MapViewOfFile函數返回一個指向共用記憶體塊的在該程式記憶體空間中有效的指標
g_pShareMemPolicy :=MapViewOfFile(
g_hShareMemPolicy , // File-mapping object 的 Handle 值
FILE_MAP_ALL_ACCESS, //設為 FILE_MAP_ALL_ACCESS 開放存取
0,
0,
//0); // 映射回來的 byte 數
SizeOf(TCmdDataWithMonitorPolicy));
//將資料寫入sharememory中
procedure TFormMain.Button1Click(Sender: TObject);
begin
PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.btData1 := 100; //壓縮率
PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.btData2 := 90; //縮放率
PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.intData1 := 5; //sessionid
PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.intData2 := 33; //usrid
PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.intData3 := 24137; //port
//IP
FillChar(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.strData1,SizeOf(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.strData1),0);
StrCopy(PCmdDataWithMonitorPolicy(g_pShareMemPolicy).strData1, PCHAR('10.1.0.3'));
//擷取端電腦名稱
FillChar(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.strData2,SizeOf(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.strData2),0);
StrCopy(PCmdDataWithMonitorPolicy(g_pShareMemPolicy).strData2, PCHAR('Yivon'));
end;
//讀取sharememory資料
procedure TForm1.Button2Click(Sender: TObject);
var
piRes :^Integer;
sTmpFileName : string;
begin
g_hShareMemPolicy := OpenFileMapping(
FILE_MAP_ALL_ACCESS, // Shared memory File，Handle 傳入 $FFFFFFFF
true,
_SMWithXMonitorPolicy); // 其他的行程將以此名稱參考到選擇共享記憶體
if g_hShareMemPolicy <> 0 then //判斷這一塊SHAREMEMORY有無配置
begin
g_pShareMemPolicy:=MapViewOfFile(
g_hShareMemPolicy, // File-mapping object 的 Handle 值
FILE_MAP_ALL_ACCESS, //設為 FILE_MAP_ALL_ACCESS 開放存取
0,
0,
//0); // 映射回來的 byte 數
SizeOf(TCmdDataWithMonitorPolicy));
Memo1.Lines.add('壓縮率：'+inttostr(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.btData1));
Memo1.Lines.add('縮放率：'+inttostr(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.btData2));
Memo1.Lines.add('SessionID：'+inttostr(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.intData1));
Memo1.Lines.add('usrid：'+inttostr(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.intData2));
Memo1.Lines.add('Port：'+inttostr(PCmdDataWithMonitorPolicy(g_pShareMemPolicy)^.intData3));
Memo1.Lines.add('IP：'+String(PCmdDataWithMonitorPolicy(g_pShareMemPolicy).strData1));
Memo1.Lines.add('CapComputerName：'+String(PCmdDataWithMonitorPolicy(g_pShareMemPolicy).strData2));
end;
end;
初始化ADOConnection函數
procedure TRecUIControl.InitADOConnectionBeginTrans(ADOConnBatchTrans: TADOConnection);
begin
// 設定ADOConnBatchTrans物件所需參數
with ADOConnBatchTrans do
begin
CommandTimeout := 300;
//ConnectOptions := coAsyncConnect; // The connection is formed asynchronously
CursorLocation := clUseServer; // Connection is client-side
LoginPrompt := False; // Don't show the login dialog when connecting to a database
Provider := 'SQLOLEDB.1'; //
ConnectionString := frmMain.ADOConnection1.ConnectionString; // 取主程式的ConnectionString
end;
end;
星期三, 7月 23, 2008
星期四, 7月 10, 2008
判斷工作管理員內的某個處理程序是否還存在
uses
Tlhelp32;
function FindProc(ProcName: string): Boolean;
var
OK: Bool;
hPL: THandle;
ProcessStruct: TProcessEntry32;
begin
Result := False;
hPL := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
ProcessStruct.dwSize := SizeOf(TProcessEntry32);
OK := Process32First(hPL, ProcessStruct);
while OK do
begin
if UpperCase(ProcessStruct.szExeFile) = UpperCase(ProcName) then
begin
Result := True;
end;
OK := Process32Next(hPL, ProcessStruct);
end;
CloseHandle(hPL);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if FindProc('bds.exe') then
begin
end;
end;
///////////////////new////////////
//加入process的數量判斷,若大於2,一定是重復執行囉~
function FindProc(ProcName: string): integer;
var
OK: Bool;
hPL: THandle;
ProcessStruct: TProcessEntry32;
i:integer;
begin
i:=0;
hPL := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
ProcessStruct.dwSize := SizeOf(TProcessEntry32);
OK := Process32First(hPL, ProcessStruct);
while OK do
begin
if UpperCase(ProcessStruct.szExeFile) = UpperCase(ProcName) then
begin
i := i+1;
end;
OK := Process32Next(hPL, ProcessStruct);
end;
Result := i;
CloseHandle(hPL);
end;
星期四, 7月 03, 2008
取得Windows的SessionID
windows xp的SessionID從0開始
windows vista的SessionID從1開始.0是給特殊權限如SYSTEM
windows vista的SessionID從1開始.0是給特殊權限如SYSTEM
function GetSessionId:DWord;
type _P2S=function (PId:DWORD; var SId:DWORD):BOOL; stdcall;
var P2S: _P2S;
Hd :HMODULE;
SId:DWord;
begin
Result:=0;
Hd:=LoadLibrary('Kernel32.dll');
if Hd<>0 then begin
@P2S:=GetProcAddress(Hd,'ProcessIdToSessionId');
if Assigned(P2S) and P2S(GetCurrentProcessId,SId) then Result:=SId;
FreeLibrary(Hd);
end;
end;
星期二, 5月 13, 2008
開啟chm某個關聯的位置網頁
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 HtmlHelpA (hwndcaller:Longint; lpHelpFile:string; wCommand:Longint;dwData:string): HWND;stdcall; external 'hhctrl.ocx'
procedure ShowChmHelp(sTopic:string);
var
i : integer;
begin
i:=HtmlHelpA(Application.Handle,Pchar('c:\windows.chm'), 0, sTopic);
if i=0 then
begin
showmessage(' help.chm幫助文件損壞！');
exit;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
tmp : integer;
begin
tmp := 10100;
case tmp of
10100: ShowChmHelp('Win32GDI/15.htm');
10101: ShowChmHelp('edtInput.htm');
else ShowChmHelp('default.htm');
end;
end;
end.
星期五, 5月 02, 2008
StrToDate可能會發生not a valid date
這是因為控制台->地區選項->日期分隔字元或型式有改變。
這是你須用程式去設定其地區選項設定
這是你須用程式去設定其地區選項設定
//設定日期格式為 yyyy/MM/dd
SetLocaleInfo(LOCALE_SYSTEM_DEFAULT, LOCALE_SSHORTDATE, 'yyyy/MM/dd') ;
//設定日曆格式為1 型式
SetLocaleInfo(LOCALE_SYSTEM_DEFAULT, LOCALE_ICALENDARTYPE, '1') ;
星期三, 4月 30, 2008
寫網卡MAC到exe檔裡，並在程式開始時做判斷
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
Edit4: TEdit;
Edit5: TEdit;
Edit6: TEdit;
Button1: TButton;
Label1: TLabel;
SaveDialog1: TSaveDialog;
Button2: TButton;
Edit7: TEdit;
Button3: TButton;
Label2: TLabel;
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type
DWordA =array [0..7] of DWord;
DWordP =^DWordA;
DWordB =array [0..7] of Byte;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button2Click(Sender: TObject);
begin
if SaveDialog1.Execute then
Edit7.Text := SaveDialog1.FileName ;
end;
function UpdateExe(N:string; ChkL:DWord; ChkH:DWord):boolean; // Write CRC to file
var
Hd,i:integer;
D,R:DWordB; // $1E
begin
Result:=False;
DWordP(@D[0])[0]:=ChkL; //20處開始由低位元塞CRC資料 若為DWordP(@D[3])[0] 則是從21處開始塞
DWordP(@D[4])[0]:=ChkH;
if FileExists(N) then
begin
Hd:=FileOpen(N,fmOpenReadWrite); //開啟N
FileSeek(Hd,$20,0);
FileWrite(Hd,D[0],8); //從20開始寫入8個byte值
FileSeek(Hd,$20,0);
FileRead(Hd,R[0],8);
//檢查
Result:=TRUE;
for i:=0 to SizeOf(D)-1 do
if D[i]<>R[i] then
begin
Result:=False;
end;
FileClose(Hd);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
m1 : DWord;
m2 : DWord;
begin
m1 := (strtoint('$'+Edit1.Text) + strtoint('$'+Edit2.Text+'00') + strtoint('$'+Edit3.Text+'0000') + strtoint('$'+Edit4.Text+'000000')) xor $AE5C2DDA;
m2 := (strtoint('$'+Edit5.Text) + strtoint('$'+Edit6.Text+'00')) xor $0000C1A3;
UpdateExe(Edit7.Text, m1, m2);
end;
function ReadFileHeader(N:string;var Chk:DWordB):boolean; // Write CRC to file
var
Hd : integer;
R : DWordB; // $1E
begin
Result:=False;
if FileExists(N) then
begin
Hd:=FileOpen(N,fmOpenRead); //開啟N
FileSeek(Hd,$20,0);
FileRead(Hd,R[0],8);
CHk := R;
Result:=True;
FileClose(Hd);
end;
end;
function MacAddress: string;
var
Lib: Cardinal;
Func: function(GUID: PGUID): Longint; stdcall;
GUID1, GUID2: TGUID;
begin
Result := '';
Lib := LoadLibrary('rpcrt4.dll');
if Lib <> 0 then
begin
if Win32Platform <>VER_PLATFORM_WIN32_NT then
@Func := GetProcAddress(Lib, 'UuidCreate')
else @Func := GetProcAddress(Lib, 'UuidCreateSequential');
if Assigned(Func) then
begin
if (Func(@GUID1) = 0) and
(Func(@GUID2) = 0) and
(GUID1.D4[2] = GUID2.D4[2]) and
(GUID1.D4[3] = GUID2.D4[3]) and
(GUID1.D4[4] = GUID2.D4[4]) and
(GUID1.D4[5] = GUID2.D4[5]) and
(GUID1.D4[6] = GUID2.D4[6]) and
(GUID1.D4[7] = GUID2.D4[7]) then
begin
Result :=
IntToHex(GUID1.D4[2] xor $DA, 2) + '-' +
IntToHex(GUID1.D4[3] xor $2D, 2) + '-' +
IntToHex(GUID1.D4[4] xor $5C, 2) + '-' +
IntToHex(GUID1.D4[5] xor $AE, 2) + '-' +
IntToHex(GUID1.D4[6] xor $A3, 2) + '-' +
IntToHex(GUID1.D4[7] xor $C1, 2);
end;
end;
FreeLibrary(Lib);
end;
end;
procedure TForm1.Button3Click(Sender: TObject);
var
R1: DWordB; // $1E
begin
ReadFileHeader(Edit7.Text, R1);
Label1.Caption:=IntToHex(R1[0],2)+'-'+IntToHex(R1[1],2)+'-'+IntToHex(R1[2],2)+'-'+IntToHex(R1[3],2)+'-'+IntToHex(R1[4],2)+'-'+IntToHex(R1[5],2);
Label2.Caption:=MacAddress;
if not SameText(Label1.Caption, Label2.Caption) then
application.Terminate ;
end;
end.
星期四, 4月 24, 2008
用訊號燈的方式，限制thread同時執行的數目
MainForm
Thread
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
FSemaphor: THandle;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses Unit2;
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FSemaphor := CreateSemaphore( nil, 3, 3, nil );
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
CloseHandle( FSemaphor );
end;
procedure TForm1.Button1Click(Sender: TObject);
var
aIndex: Integer;
aExchange: TExchange;
begin
for aIndex := 1 to 20 do
begin
if ( WaitForSingleObject( FSemaphor, INFINITE ) = WAIT_OBJECT_0 ) then
begin
aExchange := TExchange.Create( True, FSemaphor );
aExchange.FreeOnTerminate := True;
aExchange.Resume;
end;
end;
end;
end.
Thread
type
TExchange = class(TThread)
private
{ Private declarations }
FSemaphor: THandle;
protected
procedure Execute; override;
public
constructor Create(CreateSuspended:Boolean; ASemaphor: THandle); reintroduce;
end;
implementation
{ TExchange }
constructor TExchange.Create(CreateSuspended: Boolean; ASemaphor: THandle);
begin
inherited Create( CreateSuspended );
FSemaphor := ASemaphor;
end;
procedure TExchange.Execute;
begin
while not Self.Terminated do
begin
Sleep( 10000 );
Break;
end;
ReleaseSemaphore( FSemaphor, 1, nil );
end;
將組合字串還原存進TStringList陣列的方法
procedure GetSetData(CombinedStr:String;var sl:TStringList);
var
s : String;
p,l : integer;
begin
sl.Clear;
l:=Length(CombinedStr);
if l=0 then exit;
p:=1;
while p > 0 do
begin
p:=Pos(',,,',CombinedStr);
if p > 0 then
begin
s:=Copy(CombinedStr,1,p-1);
sl.Add(s);
CombinedStr:=Copy(CombinedStr,p+3,Length(CombinedStr));
end;
end;
if Length(CombinedStr) > 0 then
begin
sl.Add(CombinedStr);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
mysl : TStringList;
begin
mysl := TStringList.Create;
try
GetSetData('oo,,,ertff,,,wett' ,mysl);
caption := mysl[0]+'__'+mysl[1]+'__'+mysl[2];
finally
mysl.Free;
end;
end;
星期三, 4月 23, 2008
如何讓Button上的文字顯示二行以上
首先將Button1屬性WordWrap設為true
方法1：
在Object Inspector去點兩下修改Button的Caption，
記得使用Ctrl+Enter來換行喔!!
方法2：
接下來按ALT+F12去編輯dfm的檔案
去搜尋到Button1的caption去編輯
如：
'AAA'+#13#10+'BBB'
方法1：
在Object Inspector去點兩下修改Button的Caption，
記得使用Ctrl+Enter來換行喔!!
方法2：
接下來按ALT+F12去編輯dfm的檔案
去搜尋到Button1的caption去編輯
如：
'AAA'+#13#10+'BBB'
UpperCase轉中文字時會出現錯誤的問題
可用UpperCaseEx來取代UpperCase函數
function UpperCaseEx(const S: string): string;
var
Ch: Char;
L: Integer;
Source, Dest: PChar;
nH: Integer;
begin
L := Length(S);
SetLength(Result, L);
Source := Pointer(S);
Dest := Pointer(Result);
nH := 0;
while L <> 0 do
begin
Ch := Source^;
if nH = 0 then
if Ord(ch) >= 128 then
nH := 2;
if nH > 0 then
Dec(nH)
else
if (Ch >= 'a') and (Ch <= 'z') then Dec(Ch, 32);
Dest^ := Ch;
Inc(Source);
Inc(Dest);
Dec(L);
end;
end;
多國語言讀入字串後要注意的事
Label屬性設定
AutoSize=False
Height=20
Layout=tlcenter
ParentFont=false
TransParent=true
Button屬性設定
ParentFont=true
AutoSize=False
Height=20
Layout=tlcenter
ParentFont=false
TransParent=true
Button屬性設定
ParentFont=true
// 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];
星期五, 4月 18, 2008
截取當前的視窗(不是全螢幕)
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;
星期二, 4月 08, 2008
開始寫Delphi程式要注意的事
Project -> options > Compiler -> Code generation -> 取消勾選Optimization
Tool -> Environment Options -> Delphi Direct -> 取消勾選Automatically poll network
Form 屬性scaled設成false 屬性設字型大小建議用Height
Tool -> Environment Options -> Delphi Direct -> 取消勾選Automatically poll network
Form 屬性scaled設成false 屬性設字型大小建議用Height
星期一, 4月 07, 2008
UTC跟LocalTime
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;
星期一, 3月 31, 2008
判斷磁碟機是否有效
可判斷磁碟機，如A槽或光碟槽是否有效
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 }
星期二, 3月 25, 2008
防呆裝置，無效的按鍵不能按
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;
星期四, 3月 20, 2008
月利率來看，則存入多少金額可獲得最高報酬利率
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;
星期三, 3月 19, 2008
記錄平均cpu使用率多少的程式
主程式，新增一個TMemo，一個Timer
adCpuUsage.pas
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.
adCpuUsage.pas
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.
星期一, 3月 17, 2008
模擬ListBox按上下鍵會有游標移動的功能
目前尚有問題：未能得知第一個被選的
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;
星期一, 3月 10, 2008
星期五, 3月 07, 2008
將涵有半型及全型字串轉為全型字串
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.
星期二, 3月 04, 2008
星期五, 1月 18, 2008
取得目前(所有)的螢幕解析度及色彩
目前
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;
星期四, 1月 17, 2008
使用一個隱藏視窗在跑Timer
Unit1.pas
新增2個按鈕，並在入事件
UnitTAA.pas
新增2個按鈕，並在入事件
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.
UnitTAA.pas
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.
記錄Log的pos檔 for DebugView觀看
將UnitCommon.pas程式碼加到入的專案中。
觀看時使用以下程式碼，加到須要顯示之處
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');
星期二, 1月 08, 2008
將CRC寫入檔頭程式碼
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.
訂閱：
文章 (Atom)