مطالب بسیار خوب و مفید

آدرس کوتاه معمولا در داس مورد استفاده قرار می گیرد.

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;

با این کد می توانید یک تصویر jpg را دانلود کنید و در نهایت آن را به صورت bmp نمایش دهید(تبدیل نوع فایل پس از دانلود).مثال برا استفاده نیز درج شده است:

 

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;

با این کد می توانید به راحتی بین شکل فعلی ویندوز XP و شکل Classic تغییر دهید.

 

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.

---

اجرای Task Manager

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

 

نویسنده:Joel Fugazzotto

به درخواست یکی از عزیزان این کد را نوشتیم و در وبلاگ گذاشتیم.با این کد می توانید زبان فارسی را به ویندوز اضافه کنید.در این کد دو فایل وجود دارد که باید در کنار همین برنامه قرار گیرد.(فایلها را می توانید در سی دی ویندوز پیدا کنید).('KBDFA.dll' و 'l_intl.nls')

 

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.

با این کد یک RTF را در عکس بیاندازید.این کد RTF را همراه با تمام جزئیات (از قبیل رنگ .اندازه. شکل ) وارد تصویر می کند.

 

 

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;