استخراج آیکون از فایل هایexe va dll
استخراج آیکون از فایل هایexe va dll
کد:
Uses
Windows,
Graphics,
ShellApi;
Procedure GetIcon(Filename,IconFilename:String;SmallIcon:Boolean);
Var
HIcon32 ,
HIcon16 : HIcon;
Icon : tIcon;
Begin
ExtractIconEx(Pchar(Filename),0,HIcon32,HIcon16,1);
If (HIcon16<>0) and SmallIcon then
Begin
Icon:=tIcon.Create;
Icon.handle:=HIcon16;
Icon.SaveToFile(IconFilename);
Icon.Free;
end else
If (HIcon32<>0) and not SmallIcon then
Begin
Icon:=tIcon.Create;
Icon.handle:=HIcon32;
Icon.SaveToFile(IconFilename);
Icon.Free;
end;
End;
این تابع برنامه مورد نظر را اجر میکند و تا زمان خاتمه آن منتظر میماند.
این تابع برنامه مورد نظر را اجر میکند و تا زمان خاتمه آن منتظر میماند.
کد:
Function ExecuteAndWait(sExecutableFile : String) : Boolean;
var
siInfo : TStartUpInfo;
piInfo : TProcessInformation;
begin
FillChar(siInfo, SizeOf(siInfo), #0);
with siInfo do begin
cb := SizeOf(siInfo);
dwFlags := STARTF_USESHOWWINDOW;
wShowWindow := SW_SHOWNORMAL;
end;
Result := CreateProcess(NIL, pChar(sExecutableFile), NIL, NIL, FALSE, CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, NIL, pchar(ExtractFilePath(sExecutableFile)),siInfo, piInfo);
if Result then
WaitForSingleObject(piInfo.hprocess,INFINITE);
end;
روشن و خاموش كردن Numlock
روشن و خاموش كردن Numlock
کد:
function SetNumLock(Active: Boolean): Boolean;
begin
// Check to see if the desired state is set
if (Active <> ((GetKeyState(VK_NUMLOCK) and 1) = 1)) then
begin
// Turn on / off
keybd_event(VK_NUMLOCK, 45, KEYEVENTF_EXTENDEDKEY, 0);
keybd_event(VK_NUMLOCK, 45, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP , 0);
end;
end;
نمایش سطرهای یک Grid به صورت یکی در میان
نمایش سطرهای یک Grid به صورت یکی در میان
کد:
procedure TForm1.DBGrid1DrawColumnCell(Sender: TObject;
const Rect: TRect; DataCol: Integer; Column: TColumn;
State: TGridDrawState);
var
test1: Real;
RowNo: Integer;
begin
with (Sender as TDBGrid) do
begin
if (gdSelected in State) then
begin
// Farbe für die Zelle mit dem Focus
// color of the focused row
Canvas.Brush.Color := clblue;
end
else
begin
// Zeile erfahren
// get the actual row number
rowno := Query1.RecNo;
// gerade und ungerade Zeilen ermitteln
// odd or even ?
test1 := (RowNo / 2) - trunc(RowNo / 2);
// Zeile gerade...
// If it's an even one...
if test1 = 0 then
begin
farbe := clWhite
end
// ...Zeile ungerade
// ...else it's an odd one
else
begin
farbe := clYellow;
end;
Canvas.Brush.Color := farbe;
// Font-Farbe immer schwarz
// font color always black
Canvas.Font.Color := clBlack;
end;
Canvas.FillRect(Rect);
// Denn Text in der Zelle ausgeben
// manualy output the text
Canvas.TextOut(Rect.Left + 2, Rect.Top + 1, Column.Field.AsString);
end
end;
چگونه سایز Col را در یک DBGrid به صورت اتوماتیک قرار دهیم
چگونه سایز Col را در یک DBGrid به صورت اتوماتیک قرار دهیم
کد:
procedure SetGridColumnWidths(Grid: Tdbgrid);
const
DEFBORDER = 10;
var
temp, n: Integer;
lmax: array [0..30] of Integer;
begin
with Grid do
begin
Canvas.Font := Font;
for n := 0 to Columns.Count - 1 do
//if columns[n].visible then
lmax[n] := Canvas.TextWidth(Fields[n].FieldName) + DEFBORDER;
grid.DataSource.DataSet.First;
while not grid.DataSource.DataSet.EOF do
begin
for n := 0 to Columns.Count - 1 do
begin
//if columns[n].visible then begin
temp := Canvas.TextWidth(trim(Columns[n].Field.DisplayText)) + DEFBORDER;
if temp > lmax[n] then lmax[n] := temp;
//end; { if }
end; {for}
grid.DataSource.DataSet.Next;
end; { while }
grid.DataSource.DataSet.First;
for n := 0 to Columns.Count - 1 do
if lmax[n] > 0 then
Columns[n].Width := lmax[n];
end; { With }
end; {SetGridColumnWidths }
procedure TForm1.Button1Click(Sender: TObject);
begin
SetGridColumnWidths(dbgrid3);
end;
اضافه نمودن یک کاربر جدید داخل یک دیتابیس در SQLServer 2000
اضافه نمودن یک کاربر جدید داخل یک دیتابیس در 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 :123123@123 0
...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;
ايجاد ميانبر از يك فايل در ويندوز
کد:
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\Explorer');
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\GrpConv');
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}
minimize كردن كليه پنجره ها
کد:
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 EnumWinProc(Wnd : HWND) : Boolean; Export; StdCall;
var
WinText : Array[0..255] of Char;
begin
GetWindowText(Wnd, WinText, 255);
Result := True;
if (StrPas(WinText) <> '') and
IsWindowVisible(Wnd) and
(Wnd<>Application.Handle) and
(Wnd<>Form1.Handle)
then
CloseWindow(Wnd);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
EnumWindows(@EnumWinProc, LongInt(Self));
end;
end.