موضوع: نکات برنامه نویسی در دلفی ‏

اضافه نمودن یک کاربر جدید داخل یک دیتابیس در SQLServer 2000
کد:

procedure TForm1.Button1Click(Sender: TObject);
begin
ADOCommand1.CommandText := 'Use DataBaseName';
ADOCommand1.Execute;
ADOCommand1.CommandText := 'Exec SP_AddUser ' + QuotedStr('Username');
ADOCommand1.Execute;
end;



{* For Any Infromation Mail Me *

Mail : Mostafa@Touska.Co.ir0


...Add a user into a database in Sql Server 2000?

کنترل ولوم صدا با استفاده از کد نویسی
کد:
uses MMSystem;



type

TVolumeRec = record

case Integer of

0: (LongVolume: Longint) ;

1: (LeftVolume, RightVolume : Word) ;

end;



const DeviceIndex=5

{0:Wave

1:MIDI

2:CDAudio

3:Line-In

4:Microphone

5:Master

6:PC-loudspeaker}



procedure SetVolume(aVolume:Byte) ;

var Vol: TVolumeRec;

begin

Vol.LeftVolume := aVolume shl 8;

Vol.RightVolume:= Vol.LeftVolume;

auxSetVolume(UINT(DeviceIndex), Vol.LongVolume) ;

end;



function GetVolume:Cardinal;

var Vol: TVolumeRec;

begin

AuxGetVolume(UINT(DeviceIndex),@Vol.LongVolume) ;

Result:=(Vol.LeftVolume + Vol.RightVolume) shr 9;

end;

نحوه استفاده بررسی خالی بودن کنترل TImage
کامپوننت TImage برای نمایش تصاویر گرافیکی مورد استفاده قرار میگیرد(Ico,BMP,WMF,GIF,JPEG و مانند آن)خاصیت Picture مشخص کننده تصویری است که باید نمایش داده شود به منظور مقدار دادن به این خاصیت راههای زیادی وجود دارد: استفاده از خاصیت LoadFromFile که می توان به منظور خواندن یک فایل گرافیکی از هارد از آن استفاده کرد یا تابع Assign که می توان توسط آن تصاویر موجود در حافظه موقت(ClipBoard)
در بیشتر حالات شما تصویر خود را در زمان طراحی نرم افزار مقدار دهی میکنیدو این کار با مقدار دهی خاصیت Picture از Objectinspector امکان پذیر است
در صورتیکه میخواهید تصویر را در زمان اجرا حذف کنید مقدار خاصیت Picture را برابر با NIL قرار دهید.
و در صورتیکه بخواهید خالی بودن تصور را کنترل کنید از کد زیر استفاده کنید


کد:
if Image1.Picture.Graphic.Empty then
begin
...
end;

رنگ آمیزی کنترلهای تمکرز یافته(Focused Control)
بدین منظور میتوانید از کنترل TScreen و رویداد onActiveControlChange استفاده کنید

کد:
const
focusColor = clSkyBlue;

var
lastFocused : TWinControl;
originalColor : TColor;
توجه داشته باشید که کامپوننتی تحت عنوان TScreen برای قرار دادن روی فرم وجود ندارد و شما باید بصورت دستی رویدادها را تنظیم کنید

کد:
procedure TMainForm.FormCreate(Sender: TObject) ;
begin
Screen.OnActiveControlChange := ScreenActiveControlChange;
end;

procedure TMainForm.FormDestroy(Sender: TObject) ;
begin
Screen.OnActiveControlChange := nil;
end;
و پیاده سازی رویداد ذکر شده به صورت زیر است

کد:
procedure TMainForm.ScreenActiveControlChange(Sender: TObject) ;
var
doEnter, doExit : boolean;
previousActiveControl : TWinControl;
begin
if Screen.ActiveControl = nil then
begin
lastFocused := nil;
Exit;
end;

doEnter := true;
doExit := true;

//CheckBox
if Screen.ActiveControl is TButtonControl then doEnter := false;

previousActiveControl := lastFocused;

if previousActiveControl <> nil then
begin
//CheckBox
if previousActiveControl is TButtonControl then doExit := false;
end;

lastFocused := Screen.ActiveControl;

if doExit then ExitColor(previousActiveControl) ;
if doEnter then EnterColor(lastFocused) ;
end;

procedure TMainForm.EnterColor(Sender: TWinControl);
begin
if Sender <> nil then
begin
if IsPublishedProp(Sender,'Color') then
begin
originalColor := GetOrdProp(Sender,'Color');
SetOrdProp(Sender,'Color', focusColor);
end;
end;
end;

procedure TMainForm.ExitColor(Sender: TWinControl);
begin
if Sender <> nil then
begin
if IsPublishedProp(Sender,'Color') then
begin
SetOrdProp(Sender,'Color',originalColor);
end;
end;
end;

CheckBox در DBGrid

سلام.
با این کد می تونید در کنترل DBGrid برای مقادیر منطقی به جای True یا False از CheckBox استفاده کنید

این کد یونیت :
کد:
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, DB, DBTables, Grids, DBGrids;

type
TForm1 = class(TForm)
DBGrid1: TDBGrid;
Table1: TTable;
DataSource1: TDataSource;
procedure DBGrid1CellClick(Column: TColumn);
procedure DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
procedure DBGrid1ColEnter(Sender: TObject);
procedure DBGrid1ColExit(Sender: TObject);
private

FOriginalOptions : TDBGridOptions; { Private declarations }
public
procedure SaveBoolean;
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.SaveBoolean;
begin
Self.DBGrid1.SelectedField.Dataset.Edit;
Self.DBGrid1.SelectedField.AsBoolean := not Self.DBGrid1.SelectedField.AsBoolean;
Self.DBGrid1.SelectedField.Dataset.Post;
end;

procedure TForm1.DBGrid1CellClick(Column: TColumn);
begin
if Self.DBGrid1.SelectedField.DataType = ftBoolean then
SaveBoolean();
end;

procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn; State: TGridDrawState);
Const
CtrlState : array[Boolean] of Integer = (DFCS_BUTTONCHECK,
DFCS_BUTTONCHECK or DFCS_CHECKED);
var
CheckBoxRectangle : TRect;
begin
if Column.Field.DataType = ftBoolean then
begin
Self.DBGrid1.Canvas.FillRect(Rect);
CheckBoxRectangle.Left := Rect.Left + 2;
CheckBoxRectangle.Right := Rect.Right - 2;
CheckBoxRectangle.Top := Rect.Top + 2;
CheckBoxRectangle.Bottom := Rect.Bottom - 2;
DrawFrameControl(Self.DBGrid1.Canvas.Handle,
CheckBoxRectangle,
DFC_BUTTON,
CtrlState[Column.Field.AsBoolean]);
end;
end;
procedure TForm1.DBGrid1ColEnter(Sender: TObject);
begin
if Self.DBGrid1.SelectedField.DataType = ftBoolean then
begin
Self.FOriginalOptions := Self.DBGrid1.Options;
Self.DBGrid1.Options := Self.DBGrid1.Options - [dgEditing];
end;
end;

procedure TForm1.DBGrid1ColExit(Sender: TObject);
begin
if Self.DBGrid1.SelectedField.DataType = ftBoolean then
Self.DBGrid1.Options := Self.FOriginalOptions;
end;

end.

این هم مال فرم

object Form1: TForm1
Left = 192
Top = 114
Width = 953
Height = 778
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
PixelsPerInch = 96
TextHeight = 13
object DBGrid1: TDBGrid
Left = 0
Top = 0
Width = 945
Height = 744
Align = alClient
DataSource = DataSource1
TabOrder = 0
TitleFont.Charset = DEFAULT_CHARSET
TitleFont.Color = clWindowText
TitleFont.Height = -11
TitleFont.Name = 'MS Sans Serif'
TitleFont.Style = []
OnCellClick = DBGrid1CellClick
OnColEnter = DBGrid1ColEnter
OnColExit = DBGrid1ColExit
OnDrawColumnCell = DBGrid1DrawColumnCell
end
object Table1: TTable
Active = True
DatabaseName = 'DBDEMOS'
TableName = 'reservat.db'
Left = 128
Top = 88
end
object DataSource1: TDataSource
DataSet = Table1
Left = 176
Top = 80
end
end

تبدیل عدد به حرف
کد:
punit Curr2Str;

interface
function Add2Harf(i:int64):string;

implementation

function Add2Harf(i:int64):string;
const v=' æ ';
var
ok:boolean;
{___________________________________}
function yekan(y:byte):string;
begin
case y of
0:result:='';
1:result:='íß';
2:result:='Ïæ';
3:result:='Óå';
4:result:='چåÇÑ';
5:result:='پäÌ';
6:result:='ÔÔ';
7:result:='åÝÊ';
8:result:='åÔÊ';
9:result:='äå';
enD;
if result=''then ok:=false else ok:=true;
end;
{___________________________________}
function dahgan(y:byte):string;
begin
case y of
0:result:='';
1:result:='Ïå';
2:result:='ÈíÓÊ';
3:result:='Óí';
4:result:='چåá';
5:result:='پäÌÇå';
6:result:='ÔÕÊ';
7:result:='åÝÊÇÏ';
8:result:='åÔÊÇÏ';
9:result:='äæÏ';
enD;
if result=''then ok:=false else ok:=true;
end;
{___________________________________}
function sadgan(y:byte):string;
begin
case y of
0:result:='';
1:result:='íßÕÏ';
2:result:='ÏæíÓÊ';
3:result:='ÓíÕÏ';
4:result:='چåÇÑÕÏ';
5:result:='پÇäÕÏ';
6:result:='ÔÔÕÏ';
7:result:='åÝÊÕÏ';
8:result:='åÔÊÕÏ';
9:result:='äåÕÏ';
enD;
if result=''then ok:=false else ok:=true;
end;
{___________________________________}
function dah(y:byte):string;
begin
case y of
0:result:='';
10:result:='Ïå';
11:result:='íÇÒÏå';
12:result:='ÏæÇÒÏå';
13:result:='ÓíÒÏå';
14:result:='چåÇÑÏå';
15:result:='پÇäÒÏå';
16:result:='ÔÇäÒÏå';
17:result:='åÝÏå';
18:result:='åÌÏå';
19:result:='äæÒÏå';
enD;
if result=''then ok:=false else ok:=true;
end;
{___________________________________}
function seragham(si:smallint):string;
begin
result:='';
result:=sadgan(si div 100);
if ok then result:=result+v;

if((si mod 100)div 10) <> 1 then begin
result:=result+dahgan((si mod 100)div 10);
if ok then result:=result+v;
result:=result+yekan(si mod 10);
if not ok then result:=copy(result,1,length(result)-3);
End
else begin
result:=result+dah(si mod 100);
end;
if result='' then ok:=false else ok:=true;
end;
{___________________________________}
const
tr=' ÊÑíáíæä';
mr=' ãíáíÇÑÏ';
ml=' ãíáíæä';
hz=' åÒÇÑ';
begin
ok:=false;

result:=seragham(i div 1000000000000);
if ok then result:=result+tr+v;
result:=result+seragham((i mod 1000000000000)div 1000000000);
if ok then result:=result+mr+v;
result:=result+seragham((i mod 1000000000)div 1000000);
if ok then result:=result+ml+v;
result:=result+seragham((i mod 1000000)div 1000);
if ok then result:=result+hz+v;
result:=result+seragham(i mod 1000);
if not ok then result:=copy(result,1,length(result)-3);

if i=0 then result:='ÕÝÑ';
end;



end.

نشان دادن فرم بدون دکمه ای در تسکبار
کد:
procedure TForm1.FormCreate(Sender: TObject);
begin
SetWindowLong(Application.Handle,GWL_EXSTYLE,WS_EX_TOOLWINDOW);
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Action:=caNone;
Form1.Hide;
end;[quote][/QUOTE
--------------------بدست آوردن زمان شروع به کار ویندوز
کد:
procedure TForm1.Button1Click(Sender: TObject);
var ndayouble;
tick:Longint;
btime:TDateTime;
s:string;
begin
tick:=GetTickCount;
nday:=tick/86400000;
btime:=Now-nday;
s:='"Windows started on" dddd,mmmm d,yyyy,'+'"at" hh:nn:ss AM/PM';
showmessage( FormatDateTime(s,btime)+#10#13+
'It been up for '+IntToStr(TRUNC(nday))+' Days,'+
FormatDateTime(' h "Houre," n "minutes," s "seconds"',nday));
end;

تشخیص اتصال به شبکه
کد:
procedure TForm1.Button1Click(Sender: TObject);
begin
if GetSystemMetrics(SM_NETWORK) AND $01 = $01 then
MessageDlg('Machine is attached to network',MtInformation,[mbok],0)
else
MessageDlg('Machine is not attached to network',mtInformation,[mbok],0);
end;

ایجاد میانبر از یک فایل در ویندوز
کد:
procedure CreateShortcut(SourceFileName, Title: string; Location:
ShortcutType; SubDirectory : string);
var
MyObject : IUnknown;
MySLink : IShellLink;
MyPFile : IPersistFile;
Directory,
LinkName : string;
WFileName : WideString;
MyReg,
QuickLaunchReg : TRegIniFile;
begin
MyObject := CreateComObject(CLSID_ShellLink);
MySLink := MyObject as IShellLink;
MyPFile := MyObject as IPersistFile;

MySLink.SetPath(PChar(SourceFileName));

MyReg := TRegIniFile.Create('Software\MicroSoft\Windows\CurrentVersion\Ex plorer');
try
LinkName := ChangeFileExt(SourceFileName, '.lnk');
LinkName := ExtractFileName(LinkName);
case Location of
_DESKTOP : Directory := MyReg.ReadString('Shell Folders', 'Desktop', '');
_STARTMENU : Directory := MyReg.ReadString('Shell Folders', 'Start Menu', '');
_SENDTO : Directory := MyReg.ReadString('Shell Folders', 'SendTo', '');
_QUICKLAUNCH:
begin
QuickLaunchReg := TRegIniFile.Create('Software\MicroSoft\Windows\CurrentVersion\Gr pConv');

try
Directory := QuickLaunchReg.ReadString('MapGroups', 'Quick Launch', '');
finally
QuickLaunchReg.Free;
end; {try..finally}
end; {case _QUICKLAUNCH}
end; {case}
if Directory <> '' then
begin
if SubDirectory <> '' then
WFileName := Directory + '\'+ SubDirectory +'\' + LinkName
else
WFileName := Directory + '\' + LinkName;
MyPFile.Save(PWChar(WFileName), False);
end; {Directory <> ''}
finally
MyReg.Free;
end; {try..finally}
end; {CreateShortcut}

تشخیص اتصال به شبکه
کد:
procedure TForm1.Button1Click(Sender: TObject);
begin
if GetSystemMetrics(SM_NETWORK) AND $01 = $01 then
MessageDlg('Machine is attached to network',MtInformation,[mbok],0)
else
MessageDlg('Machine is not attached to network',mtInformation,[mbok],0);
end;

تغییر تاریخ سیستم
کد:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure FechaDelSistema(Fecha: TDateTime);
var
FecSys: TSystemTime;
nA, nM, nD: Word;
begin
DecodeDate(Fecha, nA,nM,nD);
GetLocalTime(FecSys);
FecSys.wYear := nA;
FecSys.wMonth := nM;
FecSys.wDay := nD;
SetLocalTime(FecSys);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin

FechaDelSistema( StrToDate('2006/10/09') );
end;
end.

shutdown and restart and logof windows

کد:

function WindowsExit(RebootParam: Longword): Boolean;
var
TTokenHd: THandle;
TTokenPvg: TTokenPrivileges;
cbtpPrevious: DWORD;
rTTokenPvg: TTokenPrivileges;
pcbtpPreviousRequired: DWORD;
tpResult: Boolean;
const
SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
tpResult := OpenProcessToken(GetCurrentProcess(),
TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
TTokenHd) ;
if tpResult then
begin
tpResult := LookupPrivilegeValue(nil,
SE_SHUTDOWN_NAME,
TTokenPvg.Privileges[0].Luid) ;
TTokenPvg.PrivilegeCount := 1;
TTokenPvg.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
cbtpPrevious := SizeOf(rTTokenPvg) ;
pcbtpPreviousRequired := 0;
if tpResult then
Windows.AdjustTokenPrivileges(TTokenHd,
False,
TTokenPvg,
cbtpPrevious,
rTTokenPvg,
pcbtpPreviousRequired) ;
end;
end;
Result := ExitWindowsEx(RebootParam, 0) ;
end;



نحوه استفاده


کد:
//reboot windows
ExitWindowsEx(EWX_REBOOT, 0) ;

//shut down windows
ExitWindowsEx(EWX_SHUTDOWN, 0) ;

// log off and prompt for login
ExitWindowsEx(EWX_LOGOFF, 0) ;

تصویر توسعهدهندگان دلفی 7

کافی است به محض اجرا Delphi 7 دو کلید CTRL و SHIFT را پایین نگه دارید:



به نظر شما این تصویر با چه تکنیکی capture شده است؟

تعریف آرایه های ثابت (Constant) در Delphi
با این روش:
کد:
type
TShopItem = record
Name : string;
Price : currency;
end;

const
Days : array[0..6] of string =
(
'Sun', 'Mon', 'Tue', 'Wed',
'Thu', 'Fri', 'Sat'
) ;

CursorMode : array[boolean] of TCursor =
(
crHourGlass, crSQLWait
) ;

Items : array[1..3] of TShopItem =
(
(Name : 'Clock'; Price : 20.99),
(Name : 'Pencil'; Price : 15.75),
(Name : 'Board'; Price : 42.96)
) ;

بر زدن (Shuffle) آرایه
کد:
procedure Shuffle(
var aArray;
aItemCount: Integer;
aItemSize: Integer) ;
var
Inx: Integer;
RandInx: Integer;
SwapItem: PByteArray;
A: TByteArray absolute aArray;
begin
if (aItemCount > 1) then
begin
GetMem(SwapItem, aItemSize) ;
try
for Inx := 0 to (aItemCount - 2) do
begin
RandInx := Random(aItemCount - Inx) ;
Move(A[Inx * aItemSize], SwapItem^, aItemSize) ;
Move(A[RandInx * aItemSize],
A[Inx * aItemSize], aItemSize) ;
Move(SwapItem^, A[RandInx * aItemSize],
aItemSize) ;
end;
finally
FreeMem(SwapItem, aItemSize) ;
end;
end;
end;

procedure TForm1.Button1Click(Sender: TObject) ;
var
a: array[1..54] of Integer;
i: Shortint;
begin
Randomize;
for i := Low(a) to High(a) do a := i;
Shuffle(a, High(a), SizeOf(Integer)) ;
ListBox1.Clear;
for i := 1 to High(a) - 1 do
ListBox1.Items.Add(IntToStr(a)) ;
end;

تشخیص اتصال (connection) به اینترنت (internet)
کد:
procedure TForm1.Button1Click(Sender: TObject) ;

function FuncAvail(_dllname, _funcname: string;
var _p: pointer): boolean;
{return True if _funcname exists in _dllname}
var _lib: tHandle;
begin
Result := false;
if LoadLibrary(PChar(_dllname)) = 0 then exit;
_lib := GetModuleHandle(PChar(_dllname)) ;
if _lib <> 0 then begin
_p := GetProcAddress(_lib, PChar(_funcname)) ;
if _p <> NIL then Result := true;
end;
end;

{
Call SHELL32.DLL for Win < Win98
otherwise call URL.dll
}
{button code:}
var
InetIsOffline : function(dwFlags: DWORD):
BOOL; stdcall;
begin
if FuncAvail('URL.DLL', 'InetIsOffline',
@InetIsOffline) then
if InetIsOffLine(0) = true
then ShowMessage('Not connected')
else ShowMessage('Connected!') ;
end;