Как получить список инсталлированных програм?

uses
  Registry;

procedure TForm1.Button1Click(Sender: TObject);
const
  UNINST_PATH = 'SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall';
var
  Reg: TRegistry;
  SubKeys: TStringList;
  ListItem: TlistItem;
  i: integer;
  sDisplayName, sUninstallString: string;
begin
{

  ListView1.ViewStyle := vsReport;
  ListView1.Columns.add;
  ListView1.Columns.add;
  ListView1.Columns[0].caption := 'DisplayName';
  ListView1.Columns[1].caption := 'UninstallString';
  ListView1.Columns[0].Width := 300;
  ListView1.Columns[1].Width := 300;
}
  Reg := TRegistry.Create;
  with Reg do
    try
      with ListView1.Items do
        try
          BeginUpdate;
          Clear;
          RootKey := HKEY_LOCAL_MACHINE;
          if OpenKeyReadOnly(UNINST_PATH) then
          begin
            SubKeys := TStringList.Create;
            try
              GetKeyNames(SubKeys);
              CloseKey;
              for i := 0 to subKeys.Count - 1 do
                if OpenKeyReadOnly(Format('%s\%s', [UNINST_PATH, SubKeys[i]])) then
                  try
                    sDisplayName     := ReadString('DisplayName');
                    sUninstallString := ReadString('UninstallString');
                    if sDisplayName <> '' then
                    begin
                      ListItem         := Add;
                      ListItem.Caption := sDisplayName;
                      ListItem.subitems.Add(sUninstallString);
                    end;
                  finally
                    CloseKey;
                  end;
            finally
              SubKeys.Free;
            end;
          end;
        finally
          ListView1.AlphaSort;
          EndUpdate;
        end;
    finally
      CloseKey;
      Free;
    end;
end;

Взято с сайта

Как получить список папок Outlook?

uses
  ComObj;

procedure RetrieveOutlookFolders(tvFolders: TTreeView);

  procedure LoadFolder(ParentNode: TTreeNode; Folder: OleVariant);
  var
    i: Integer;
    Node: TTreeNode;
  begin
    for i := 1 to Folder.Count do
    begin
      Node := tvFolders.Items.AddChild(ParentNode, Folder.Item[i].Name);

      LoadFolder(Node, Folder.Item[i].Folders);
    end;
  end;
var
  outlook, NameSpace: OLEVariant;
begin
  outlook   := CreateOleObject('Outlook.Application');
  NameSpace := outlook.GetNameSpace('MAPI');

  LoadFolder(nil, NameSpace.Folders);

  outlook := Unassigned;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  RetrieveOutlookFolders(TreeView1);
end;

Взято с сайта

Как получить список процессов?

function IsRunning( sName : string ) : boolean;
var
  han : THandle;
  ProcStruct : PROCESSENTRY32; // from "tlhelp32" in uses clause
  sID : string;
begin
  Result := false;
  // Get a snapshot of the system
  han := CreateToolhelp32Snapshot( TH32CS_SNAPALL, 0 );
  if han = 0 then
    exit;
  // Loop thru the processes until we find it or hit the end
  ProcStruct.dwSize := sizeof( PROCESSENTRY32 );
  if Process32First( han, ProcStruct ) then
    begin
      repeat
        sID := ExtractFileName( ProcStruct.szExeFile );
        // Check only against the portion of the name supplied, ignoring case
        if uppercase( copy( sId, 1, length( sName ) ) ) = uppercase( sName ) then
          begin
            // Report we found it
            Result := true;
            Break;
          end;
      until not Process32Next( han, ProcStruct );
    end;
  // clean-up
  CloseHandle( han );
end;

Взято с Исходников.ru

Как получить список таблиц?

A list of user tables can be retrieved by querying system table rdb$relations.

The example below shows how to do this - it inserts the table names sorted alphabetically into a ListBox (lbSourceTables).

begin
ibcSourceList.SQL.Clear;
  ibcSourceList.SQL.Add('select rdb$relation_name from rdb$relations');
  ibcSourceList.SQL.Add('where rdb$system_flag = 0');
  ibcSourceList.SQL.Add('order by rdb$relation_name');
  ibcSourceList.Open;
  while not ibcSourceList.Eof do
  begin
    lbSourceTables.Items.Add(ibcSourceList.Fields[0].AsString);
    ibcSourceList.Next;
  end;
  ibcSourceList.Close;
end;

Взято с

Delphi Knowledge Base

Как получить список таблиц в базе Access?

t:Tstringlist;
...
ADOConnection.GetTableNames(t)

Автор:

Vit

Взято из

Как получить список установленных модемов в Win95/98?

unit PortInfo;

interface

uses Windows, SysUtils, Classes, Registry;

function EnumModems: TStrings;

implementation

function EnumModems: TStrings;

var

  R: TRegistry;
  s: ShortString;
  N: TStringList;
  i: integer;
  j: integer;
begin

  Result := TStringList.Create;
  R := TRegistry.Create;
  try
    with R do
      begin
        RootKey := HKEY_LOCAL_MACHINE;
        if OpenKey('\System\CurrentControlSet\Services\Class\Modem', False) then
          if HasSubKeys then
            begin
              N := TStringList.Create;
              try
                GetKeyNames(N);
                for i := 0 to N.Count - 1 do
                  begin
                    closekey; { + }
                    openkey('\System\CurrentControlSet\Services\Class\Modem', false); { + }
                    OpenKey(N[i], False);
                    s := ReadString('AttachedTo');
                    for j := 1 to 4 do
                      if Pos(Chr(j + Ord('0')), s) > 0 then
                        Break;
                    Result.AddObject(ReadString('DriverDesc'), TObject(j));
                    CloseKey;
                  end;
              finally
                N.Free;
              end;
            end;
      end;
  finally
    R.Free;
  end;
end;

end.

Взято с сайта

Как получить средний цвет между двумя цветами?

functionGetColorBetween(StartColor, EndColor: TColor; Pointvalue, Von, Bis:
  Extended): TColor;
var
  F: Extended;
  r1, r2, r3, g1, g2, g3, b1, b2, b3: Byte;
  function CalcColorBytes(fb1, fb2: Byte): Byte;
  begin
    result := fb1;
    if fb1 < fb2 then
      Result := FB1 + Trunc(F * (fb2 - fb1));
    if fb1 > fb2 then
      Result := FB1 - Trunc(F * (fb1 - fb2));
  end;
begin
  if Pointvalue <= Von then
  begin
    result := StartColor;
    exit;
  end;
  if Pointvalue >= Bis then
  begin
    result := EndColor;
    exit;
  end;
  F := (Pointvalue - von) / (Bis - Von);
  asm
     mov EAX, Startcolor
     cmp EAX, EndColor
     je @@exit
     mov r1, AL
     shr EAX,8
     mov g1, AL
     shr Eax,8
     mov b1, AL
     mov Eax, Endcolor
     mov r2, AL
     shr EAX,8
     mov g2, AL
     shr EAX,8
     mov b2, AL
     push ebp
     mov al, r1
     mov dl, r2
     call CalcColorBytes
     pop ecx
     push ebp
     Mov r3, al
     mov dL, g2
     mov al, g1
     call CalcColorBytes
     pop ecx
     push ebp
     mov g3, Al
     mov dL, B2
     mov Al, B1
     call CalcColorBytes
     pop ecx
     mov b3, al
     XOR EAX,EAX
     mov AL, B3
     SHL EAX,8
     mov AL, G3
     SHL EAX,8
     mov AL, R3
     @@Exit:
     mov @result, eax
  end;
end;

//------------------------------------------------------------------------------
// Function for getting mixed color from two given colors, with a relative
// distance from two colors determined by Position value inside
// MinPosition..MaxPosition range
// Author: Dmitri Papichev (c) 2001
// License type: Freeware
//------------------------------------------------------------------------------

function GetMixedColor(const StartColor,
  EndColor: TColor;
  const MinPosition,
  Position,
  MaxPosition: integer): TColor;
var
  Fraction: double;
  R, G, B,
    R0, G0, B0,
    R1, G1, B1: byte;
begin
  {process Position out of range situation}
  if (MaxPosition < MinPosition) then
  begin
    raise Exception.Create
      ('GetMixedColor: MaxPosition is less then MinPosition');
  end; {if}

  {if Position is outside MinPosition..MaxPosition range, the closest boundary
   is effectively substituted through the adjustment of Fraction}
  Fraction :=
    Min(1, Max(0, (Position - MinPosition) / (MaxPosition - MinPosition)));

  {extract the intensity values}
  R0 := GetRValue(StartColor);
  G0 := GetGValue(StartColor);
  B0 := GetBValue(StartColor);
  R1 := GetRValue(EndColor);
  G1 := GetGValue(EndColor);
  B1 := GetBValue(EndColor);

  {calculate the resulting intensity values}
  R := R0 + Round((R1 - R0) * Fraction);
  G := G0 + Round((G1 - G0) * Fraction);
  B := B0 + Round((B1 - B0) * Fraction);

  {combine intensities in a resulting color}
  Result := RGB(R, G, B);
end; {--GetMixedColor--}

Взято с

Delphi Knowledge Base

Как получить статус принтера?

function TestPrinterStatus(LPTPort: Word): Byte;
var
  Status: byte;
  CheckLPT: word;
begin
  Status := 0;
  if (LPTPort >= 1) and (LPTPort <= 3) then
  begin
    CheckLPT := LPTPort - 1;
    asm
      mov dx, CheckLPT;
      mov al, 0;
      mov ah, 2;
      int 17h;
      mov &Status, ah;
    end;
  end;
  Result := Status;
end;

{
  Pass in the LPT port number you want to check & get the following back:
  01h - Timeout
  08h - I/O Error
  10h - Printer selected
  20h - Out of paper
  40h - Printer acknowledgement
  80h - Printer not busy (0 if busy)

  Note:
  This function doesn't work under NT, it gives an access violation
  from the DOS interrupt call.
}

Взято с сайта

Как получить строковое значение перечисляемого типа?

procedure GetEnumNameList(Pti: PTypeInfo; AList:
                               TStrings; X: Integer);
{(**********************************************************
Will return in AList string version of an
enumerated type less the first X characters .
eg X = 4
and
          type
            eXORBuySell = (
              XOR_BUY,
              XOR_SELL
            );

GetEnumNameList(TypeInfo(eXORBuySell), ComboBox1.Items, 4);

Now  ComboBox1.Items[0] = 'BUY'
and  ComboBox1.Items[1] = 'SELL'
************************************************************)}
var
  I: Integer;
begin
  AList.Clear;
  with GetTypeData(pti)^ do
  for I := MinValue to MaxValue do
    AList.Add(Copy(GetEnumName(pti, I), X + 1, 255));
end;

Взято с сайта

Как получить строковый путь узла TTreeView?

{*---------------------------------------------
Parent Text
---------------------------------------------*}

function SrNodeTree(pTreeNode: TTreeNode; var sRuta: string): string;
begin
  sRuta := pTreeNode.Text + ' > ' + sRuta;
  if pTreeNode.Level = 0 then Result := sRuta
  else
    Result := SrNodeTree(pTreeNode.Parent, sRuta);
end;

{*---------------------------------------------
  Click an Item
---------------------------------------------*}
procedure TForm1.TreeView1Click(Sender: TObject);
var
  sPath: string;
begin
  label1.Caption := SrNodeTree(TreeView1.Selected, sPath);
end;

Взято с сайта

Как получить текущее время?

InterBase supports four DATE literals. They are: 'today', 'yesterday', 'tomorrow' and 'now'
Use it with a cast as shown in the example below.

insertinto mytable values(cast('now' as DATE), 'Test')

Взято с

Delphi Knowledge Base

Как получить текущую дату?

//make the SQL dependent on type of DBMS

if AppLibrary.Database.DriverName = 'ORACLE' then
SQL.Add('and entry_date < SYSDATE')
else
SQL.Add('and entry_date < "TODAY"');
end;

Взято с

Delphi Knowledge Base

Как получить TextRange страницы без фреймов?

HTML_Doc := WebBrowser1.Document As IHTMLDocument2;
Window := HTML_Doc.parentWindow As IHTMLWindow2;
Body := HTML_Doc.get_body As IHTMLBodyElement;
Range := oBody.createTextRange;

Можно еще так:

var
a:IHTMLTxtRange;
a:=IHTMLDocument2(webbrowser1.Document).selection.createRange as IHTMLTxtRange;

Автор ответа: Good Man
Взято с Vingrad.ru

Как получить UNC путь к файлу?

functionGetUNCName(PathStr: string): string;
var
  bufSize: DWord;
  buf: TUniversalNameInfo;
  msg: string;
begin
  bufSize := SizeOf(TUniversalNameInfo);
  if (WNetGetUniversalName(PChar(PathStr), UNIVERSAL_NAME_INFO_LEVEL,
    buf, bufSize) > 0) then
    case GetLastError of
      ERROR_BAD_DEVICE: msg := 'ERROR_BAD_DEVICE';
      ERROR_CONNECTION_UNAVAIL: msg := 'ERROR_CONNECTION_UNAVAIL';
      ERROR_EXTENDED_ERROR: msg := 'ERROR_EXTENDED_ERROR';
      ERROR_MORE_DATA: msg := 'ERROR_MORE_DATA';
      ERROR_NOT_SUPPORTED: msg := 'ERROR_NOT_SUPPORTED';
      ERROR_NO_NET_OR_BAD_PATH: msg := 'ERROR_NO_NET_OR_BAD_PATH';
      ERROR_NO_NETWORK: msg := 'ERROR_NO_NETWORK';
      ERROR_NOT_CONNECTED: msg := 'ERROR_NOT_CONNECTED';
    end
  else
    msg := buf.lpUniversalName;

  Result := msg;
end;

Работает только на NT/2000/XP

Взято с

Delphi Knowledge Base

Как получить / установить приоритет процесса?

Const
    ppIdle                  : Integer = -1;
    ppNormal                : Integer =  0;
    ppHigh                  : Integer =  1;
    ppRealTime              : Integer =  2;

Function SetProcessPriority( Priority : Integer ) : Integer;
Var
    H : THandle;
Begin
    Result := ppNormal;
    H := GetCurrentProcess();
    If ( Priority = ppIdle ) Then
        SetPriorityClass( H, IDLE_PRIORITY_CLASS )
    Else If ( Priority = ppNormal ) Then
        SetPriorityClass( H, NORMAL_PRIORITY_CLASS )
    Else If ( Priority = ppHigh ) Then
        SetPriorityClass( H, HIGH_PRIORITY_CLASS )
    Else If ( Priority = ppRealTime ) Then
        SetPriorityClass( H, REALTIME_PRIORITY_CLASS );
    Case GetPriorityClass( H ) Of
        IDLE_PRIORITY_CLASS     : Result := ppIdle;
        NORMAL_PRIORITY_CLASS   : Result := ppNormal;
        HIGH_PRIORITY_CLASS     : Result := ppHigh;
        REALTIME_PRIORITY_CLASS : Result := ppRealTime;
    End;
End;

Function GetProcessPriority : Integer;
Var
    H : THandle;
Begin
    Result := ppNormal;
    H := GetCurrentProcess();
    Case GetPriorityClass( H ) Of
        IDLE_PRIORITY_CLASS     : Result := ppIdle;
        NORMAL_PRIORITY_CLASS   : Result := ppNormal;
        HIGH_PRIORITY_CLASS     : Result := ppHigh;
        REALTIME_PRIORITY_CLASS : Result := ppRealTime;
    End;
End;

Как использовать:

    Function SetProcessPriority( Priority : Integer ) : Integer;

для установки приоритета Вашего приложения, либо:

    Function GetProcessPriority : Integer;

для получения приоритета.

Взято с Исходников.ru

Как получить версию моей DLL?

procedure GetFileVersion(FileName: string; var Major1, Major2,
    Minor1, Minor2: Integer);
  var
    Info: Pointer;
    InfoSize: DWORD;
    FileInfo: PVSFixedFileInfo;
    FileInfoSize: DWORD;
    Tmp: DWORD;
  begin
    InfoSize := GetFileVersionInfoSize(PChar(FileName), Tmp);
    if InfoSize = 0 then
      //Файл не содержит информации о версии
    else
    begin
      GetMem(Info, InfoSize);
      try
        GetFileVersionInfo(PChar(FileName), 0, InfoSize, Info);
        VerQueryValue(Info, '\', Pointer(FileInfo), FileInfoSize);
        Major1 := FileInfo.dwFileVersionMS shr 16;
        Major2 := FileInfo.dwFileVersionMS and $FFFF;
        Minor1 := FileInfo.dwFileVersionLS shr 16;
        Minor2 := FileInfo.dwFileVersionLS and $FFFF;
      finally
        FreeMem(Info, FileInfoSize);
      end;
    end;
  end;

Взято с Исходников.ru

Как получить версию Windows?

Type TOSVersion=(osUnknown, osUnknown9x, osUnknownNT, osWin95, osWin98, osWin98SE, osWinME, osWinNT, osWin2000, osXP);

function GetOSVersion : TOSVersion;
var osVerInfo : TOSVersionInfo;
majorVer, minorVer : Integer;
begin
result := OsUnknown;
osVerInfo.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
if GetVersionEx(osVerInfo) then
begin
majorVer := osVerInfo.dwMajorVersion;
minorVer := osVerInfo.dwMinorVersion;
case osVerInfo.dwPlatformId of
VER_PLATFORM_WIN32_NT :
Case majorVer of
4:result := OsWinNT;
5:if minorVer=0 then result := OsWin2000
else
if minorVer=1 then result := OsXP else result := osUnknownNT;
else result := osUnknownNT;
end; {Case majorVer of}
VER_PLATFORM_WIN32_WINDOWS :
case majorVer of
4: Case minorVer of
0:result := OsWin95;
10: if osVerInfo.szCSDVersion[1] = 'A' then result := OsWin98SE else result := OsWin98;
90: result := OsWinME;
else result := osUnknown9x;
end;{Case minorVer of}
else result := osUnknown9x;
end{case majorVer of}
else result := OsUnknown;
end;{case osVerInfo.dwPlatformId of}
end;{if GetVersionEx(osVerInfo) then}
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
case GetOSVersion of
osUnknown: Showmessage('Unknown');
osWin95: Showmessage('Win95');
osWin98: Showmessage('Win98');
osWin98SE: Showmessage('Win98SE');
osWinME: Showmessage('WinME');
osWinNT: Showmessage('WinNT');
osWin2000: Showmessage('Win2000');
osXP: Showmessage('XP');
end;
end;

Как получить версию Windows?

procedure TForm1.WinVer;
var WinV: Word;
begin
WinV := GetVersion AND $0000FFFF;
Edit6.Text := IntToStr(Lo(WinV))+'.'+IntToStr(Hi(WinV));
end;

Функция выдает следующее - 4.10
Как можно таким же простым способом получить полную версию - 4.10.222

Автор ответа: inko
Взято с Vingrad.ru

Как получить версию Windows?

Вот еще один пример. Мне он нравиться больше всего. Я его обычно использую в своих программах. Он гибкий и предоставляет максимум информации.

{Объявление процедур и констант}
function GetWindowsVersion1: string;
function WhatWindowsIsInstalled : String;
const
VER_NT_WORKSTATION = 0;
VER_NT_DOMAIN_CONTROLLER = 1;
VER_NT_SERVER = 2;

VER_SUITE_SMALLBUSINESS = 1;
VER_SUITE_ENTERPRISE = 2;
VER_SUITE_BACKOFFICE = 4;
VER_SUITE_COMMUNICATIONS = 8;
VER_SUITE_TERMINAL = $10;
VER_SUITE_SMALLBUSINESS_RESTRICTED = $20;
VER_SUITE_EMBEDDEDNT = $40;
VER_SUITE_DATACENTER = $80;
VER_SUITE_SINGLEUSERTS = $100;
VER_SUITE_PERSONAL = $200;
VER_SUITE_BLADE = $400;

type
TOsVersionInfoExA = packed record
old : TOsVersionInfoA;
wServicePackMajor : Word;
wServicePackMinor : Word;
{
wSuiteMask
Набор битовых флагов, определяющих компоненты Windows
VER_SUITE_BACKOFFICE Установлен компонент Microsoft BackOffice.
VER_SUITE_BLADE Установлен компонент Windows .NET Web Server.
VER_SUITE_DATACENTER Установлена Windows 2000 или компонент Windows .NET
Datacenter Server
VER_SUITE_ENTERPRISE Установлена Windows 2000 Advanced Server или компонент
Windows .NET Enterprise Server.
VER_SUITE_PERSONAL Установлена Windows XP Home Edition.
VER_SUITE_SMALLBUSINESS Установлен Microsoft Small Business Server.
VER_SUITE_SMALLBUSINESS_RESTRICTED Установлен Microsoft Small Business
Server с ограничительной лицензией для клиентов
VER_SUITE_TERMINAL Установлен компонент Terminal Services.
}

wSuiteMask : Word;
{wProductType Дополнительная информация о типе операционной системы
VER_NT_WORKSTATION Операционная система Windows NT 4.0 Workstation,
Windows 2000 Professional,
Windows XP Home Edition, или
Windows XP Professional.
VER_NT_DOMAIN_CONTROLLER Операционная система является контроллером домена.
VER_NT_SERVER Операционная система является сервером.
}

wProductType : Byte;
wReserved : Byte;
end;

...

{Реализация}
function WhatWindowsIsInstalled : String;
var VerInfo : TOsVersionInfoExA;
begin
FillChar(VerInfo, sizeof(VerInfo), 0);
VerInfo.old.dwOSVersionInfoSize := Sizeof(TOsVersionInfoExA);
if NOT GetVersionExA(VerInfo.old) then
begin
VerInfo.old.dwOSVersionInfoSize := Sizeof(TOsVersionInfoA);
GetVersionExA(VerInfo.old);
end;
case VerInfo.old.dwPlatformId of
VER_PLATFORM_WIN32_WINDOWS:
  if  (Verinfo.old.dwMajorVersion = 4) AND
  (Verinfo.old.dwBuildNumber = 950) then Result := 'Windows 95' else
  if  (Verinfo.old.dwMajorVersion = 4) AND
  (Verinfo.old.dwMinorVersion = 10) AND
  (Verinfo.old.dwBuildNumber = 1998) then Result := 'Windows 98' else
  if (Verinfo.old.dwMinorVersion = 90) then Result := 'Windows Me';
VER_PLATFORM_WIN32_NT:
if Verinfo.old.dwMajorVersion = 3 then Result := 'Windows NT 3.51' else
if Verinfo.old.dwMajorVersion = 4 then Result := 'Windows NT 4.0' else
if Verinfo.old.dwMajorVersion = 5 then
if Verinfo.old.dwMinorVersion = 0 then Result := 'Windows 2000' else
if Verinfo.old.dwMinorVersion = 1 then Result := 'Windows XP';
VER_PLATFORM_WIN32s: Result := 'Win32s';
end;
end;

function GetWindowsVersion1: string;
{$IFDEF WIN32}
const sWindowsVersion = '%.3d';
var
Ver: TOsVersionInfo;
Platform: string[4];
begin
Ver.dwOSVersionInfoSize := SizeOf(Ver);
GetVersionEx(Ver);
with Ver do begin
case dwPlatformId of
VER_PLATFORM_WIN32s: Platform := '32s';
VER_PLATFORM_WIN32_WINDOWS:
begin
dwBuildNumber := dwBuildNumber and $0000FFFF;
if (dwMajorVersion > 4) or ((dwMajorVersion = 4) and (dwMinorVersion >= 10)) then Platform := '98'
else Platform := '95';
end;
VER_PLATFORM_WIN32_NT: Platform := 'NT';
end;
Result := Trim(Format(sWindowsVersion, [dwBuildNumber]));
end;
end;
{$ELSE}
const
sWindowsVersion = 'Windows%s %d.%d';
sNT: array[Boolean] of string[3] = ('', ' NT');
var
Ver: Longint;
begin
Ver := GetVersion;
Result := Format(sWindowsVersion, [sNT[not Boolean(HiByte(LoWord(Ver)))],
LoByte(LoWord(Ver)), HiByte(LoWord(Ver))]);
end;
{$ENDIF WIN32}

Пример вызова
Label1.Caption := WhatWindowsIsInstalled+' (Build '+GetWindowsVersion1+')';

Автор Pegas
Взято с Vingrad.ru

Как получить весь размер системной памяти?

function GetMemoryTotalPhys : DWord;
var
memStatus: TMemoryStatus;
begin
memStatus.dwLength := sizeOf ( memStatus );
GlobalMemoryStatus ( memStatus );
Result := memStatus.dwTotalPhys;
end;

Взято с Исходников.ru

Как получить закэшированные пароли в Win9x?

program getpass;
........
type
...
ListBox: TListBox;
procedure getpasswords;
.......
end;

const Count: Integer = 0;

function WNetEnumCachedPasswords(lp: lpStr; w: Word; b: Byte; PC: PChar; dw: DWord): Word; stdcall;

implementation

{$R *.DFM}

function WNetEnumCachedPasswords(lp: lpStr; w: Word; b: Byte; PC: PChar; dw: DWord): Word; external mpr name 'WNetEnumCachedPasswords';
type
PWinPassword = ^TWinPassword;
TWinPassword = record
   EntrySize: Word;
   ResourceSize: Word;
   PasswordSize: Word;
   EntryIndex: Byte;
   EntryType: Byte;
   PasswordC: Char;
  end;
var
  WinPassword: TWinPassword;

function AddPassword(WinPassword: PWinPassword; dw: DWord): LongBool; stdcall;
var
  Password: String;
  PC: Array[0..$FF] of Char;
begin
  inc(Count);

  Move(WinPassword.PasswordC, PC, WinPassword.ResourceSize);
  PC[WinPassword.ResourceSize] := #0;
  CharToOem(PC, PC);
  Password := StrPas(PC);

  Move(WinPassword.PasswordC, PC, WinPassword.PasswordSize + WinPassword.ResourceSize);
  Move(PC[WinPassword.ResourceSize], PC, WinPassword.PasswordSize);
  PC[WinPassword.PasswordSize] := #0;
  CharToOem(PC, PC);
  Password := Password + ': ' + StrPas(PC);

  Form1.ListBox.Items.Add(Password);
  Result := True;
end;

procedure tform1.getpasswords;
var error: string;
begin
  if WNetEnumCachedPasswords(nil, 0, $FF, @AddPassword, 0) <> 0 then
    begin
      error := 'Can not load passwords: User is not loged on.';
    end
  else if Count = 0 then
    error := 'No passwords found...'
end;

Взято с Исходников.ru

Как получить значение свойства в виде варианта по тексту имени свойства?

unitMorePropInfo;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TFrmMorePropInfo = class(TForm)
    Button1: TButton;
    Button2: TButton;
    ListBox1: TListBox;
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FrmMorePropInfo: TFrmMorePropInfo;

implementation

{$R *.DFM}

uses
  TypInfo;

procedure GetPropertyValues(AObj: TObject; AValues: TStrings);
var
  count: integer;
  data: PTypeData;
  default: string;
  i: integer;
  info: PTypeInfo;
  propList: PPropList;
  propInfo: PPropInfo;
  propName: string;
  value: variant;
begin
  info := AObj.ClassInfo;
  data := GetTypeData(info);
  GetMem(propList, data^.PropCount * SizeOf(PPropInfo));
  try
    count := GetPropList(info, tkAny,  propList);
    for i := 0 to count - 1 do
    begin
      propName := propList^[i]^.Name;
      propInfo := GetPropInfo(info, propName);
      if propInfo <> nil then
      begin
        case propInfo^.PropType^.Kind of
          tkClass, tkMethod:
            value := '$' + IntToHex(GetOrdProp(AObj, propInfo), 8);
          tkFloat:
            value := GetFloatProp(AObj, propInfo);
          tkInteger:
            value := GetOrdProp(AObj, propInfo);
          tkString, tkLString, tkWString:
            value := GetStrProp(AObj, propInfo);
          tkEnumeration:
            value := GetEnumProp(AObj, propInfo);
          else
            value := '???';
        end;
        if propInfo.default = longint($80000000) then
          default := 'none'
        else
          default := IntToStr(propInfo.default);
        AValues.Add(Format('%s: %s [default: %s]', [propName, value, default]));
        {$80000000 apparently indicates "no default"}
      end;
    end;
  finally
    FreeMem(propList, data^.PropCount * SizeOf(PPropInfo));
  end;
end;

procedure TFrmMorePropInfo.Button2Click(Sender: TObject);
var
  count: integer;
  data: PTypeData;
  i: integer;
  info: PTypeInfo;
  propList: PPropList;
  propInfo: PPropInfo;
  propName: string;
  propVal: variant;
  tmpS: string;
begin
  info := Button2.ClassInfo;
  data := GetTypeData(info);
  GetMem(propList, data^.PropCount * SizeOf(PPropInfo));
  try
    count := GetPropList(info, tkAny,  propList);
    ListBox1.Clear;
    for i := 0 to count - 1 do
    begin
      propName := propList^[i]^.Name;
      propInfo := GetPropInfo(info, propName);
      if propInfo <> nil then
      begin
        case propInfo^.PropType^.Kind of
          tkClass, tkMethod:
            propVal := '$' + IntToHex(GetOrdProp(Button2, propInfo), 8);
          tkFloat:
            propVal := GetFloatProp(Button2, propInfo);
          tkInteger:
            propVal := GetOrdProp(Button2, propInfo);
          tkString, tkLString, tkWString:
            propVal := GetStrProp(Button2, propInfo);
          tkEnumeration:
            propVal := GetEnumProp(Button2, propInfo);
          else
            propVal := '...';
        end;
        tmpS := propVal;
        ListBox1.Items.Add(Format('%s: %s [default: %s]', [propName, tmpS, '$'
                                             + IntToHex(propInfo.default, 8)]));
        {$80000000 apparently indicates "no default"}
      end;
    end;
  finally
    FreeMem(propList, data^.PropCount * SizeOf(PPropInfo));
  end;
end;

end.

Tip by Ralph Friedman

Взято из

Как получитьописание кода, полученного GetLastError?

Функция RTL SysErrorMessage(GetLastError).

procedure TForm1.Button1Click(Sender: TObject);
begin
{Cause a Windows system error message to be logged}
ShowMessage(IntToStr(lStrLen(nil)));
ShowMessage(SysErrorMessage(GetLastError));
end;

Как пользоваться командой шела - MinimizeAll?

Для этого надо импортировать Microsoft Shell Controls & Automation Type Library.

В меню Project..Import Type Library

Выберите Microsoft Shell Controls & Automation (version 1.0).

Нажмите Install...

На панели компонентов, в закладке ActiveX появится несколько компонентов. Перетащите на форму компонент TShell. После этого, например, можно всё минимизировать:

Shell1.MinimizeAll;

/*********************************************************************
  Так же в этом компоненте присутствует давольно много забавных примочек.
*********************************************************************/
procedure TForm1.Shell(sMethod: Integer);
begin
  case sMethod of
  0:
     //Минимизируем все окна на рабочем столе
   begin
     Shell1.MinimizeAll;
     Button1.Tag := Button1.Tag + 1;
   end;
  1:
     //Показываем диалоговое окошко Run
   begin
     Shell1.FileRun;
     Button1.Tag := Button1.Tag + 1;
   end;
  2:
     //Показываем окошко завершения работы Windows
   begin
     Shell1.ShutdownWindows;
     Button1.Tag := Button1.Tag + 1;
   end;
  3:
     //Показываем окно поиска файлов
   begin
     Shell1.FindFiles;
     Button1.Tag := Button1.Tag + 1;
   end;
  4:
     //Отображаем окно настройки времени и даты
   begin
     Shell1.SetTime;
     Button1.Tag := Button1.Tag + 1;
   end;
  5:
     //Показываем диалоговое окошко настройки интернета (Internet Properties)
   begin
     Shell1.ControlPanelItem('INETCPL.cpl');
     Button1.Tag := Button1.Tag + 1;
   end;
  6:
     //Предлагаем пользователю выбрать директорию из Program Files
   begin
     Shell1.BrowseForFolder(0, 'My Programs', 0, 'C:\Program Files');
     Button1.Tag := Button1.Tag + 1;
   end;
  7:
     //Показываем диалоговое окошко настройки панели задач
   begin
     Shell1.TrayProperties;
     Button1.Tag := Button1.Tag + 1;
   end;
   8:
     //Восстанавливаем все окна на рабочем столе
   begin
     Shell1.UndoMinimizeAll;
     Button1.Tag := 0;
   end;
  end; {case}
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Shell(Button1.Tag);
end;

Взято с Исходников.ru

Как поменять border страницы?

{... }
var
Rng: OleVariant;
LeftEdge: Border;
{ ... }
WS.Range['A5', 'D5'].Borders.Item[xlEdgeTop].Weight := xlThick;
WS.Range['A5', 'D5'].Borders.Item[xlEdgeTop].Color := clYellow;
WS.Range['A5', 'D5'].Borders.Item[xlEdgeBottom].Linestyle := xlDouble;
WS.Range['A5', 'D5'].Borders.Item[xlEdgeBottom].Color := clYellow;
{ ... }

{ ... }
WS.Evaluate('B6, C6, D6, E6, F6').Borders.Item[xlEdgeLeft].Line
style := xlContinuous;
Rng := WS.Range['A1', 'A1'];
Rng.BorderAround(xlContinuous, xlThin, Color := clFuchsia);
LeftEdge := WS.Range['B2', 'B5'].Borders.Item[xlEdgeLeft];
LeftEdge.Linestyle := xlContinuous;
LeftEdge.Weight := 3;
LeftEdge.Color := clLime;
{ ... }

Взято с

Delphi Knowledge Base

Как поменять функции кнопок мышки?

Begin
//---------
SwapMouseButton(true); // Поменять обратно - SwapMouseButton(false);
//---------
end;

Взято с Исходников.ru

Как поменять иконку и стpокy в заголовке консольного окна?

procedureTForm1.Button1Click(Sender: TObject);
var
  h: HWND;
  AIcon: TIcon;
begin
  AllocConsole;
  SetConsoleTitle(PChar('Console Title'));
  Sleep(0);
  h := FindWindow(nil, PChar('Console Title'));
  AIcon := TIcon.Create;
  ImageList1.GetIcon(0, AIcon);
  SendMessage(h, WM_SETICON, 1, AIcon.Handle);
  AIcon.Free;
end;

Взято с

Как поменять приоритет моего приложения?

procedureTForm1.Button1Click(Sender: TObject);
var
  ProcessID: DWORD;
  ProcessHandle: THandle;
  ThreadHandle: THandle;
begin
  ProcessID := GetCurrentProcessID;
  ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION,
    false, ProcessID);
  SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS);
  ThreadHandle := GetCurrentThread;
  SetThreadPriority(ThreadHandle, THREAD_PRIORITY_TIME_CRITICAL);
end;

Взято с

Как поменять ссылку в тексте?

{... }
Doc := Word.ActiveDocument;
for x := 1 to Doc.Hyperlinks.Count do
begin
Doc.Hyperlinks.Item(x).Address;
end;
{ ... }

Взято с

Delphi Knowledge Base

Как поместить битмап в метафайл

Следующий пример демонстрирует рисование битмапа в метафайле.

procedure TForm1.Button1Click(Sender: TObject);
var
  m : TmetaFile;
  mc : TmetaFileCanvas;
  b : tbitmap;
begin
  m := TMetaFile.Create;
  b := TBitmap.create;
  b.LoadFromFile('C:\SomePath\SomeBitmap.BMP');
  m.Height := b.Height;
  m.Width := b.Width;
  mc := TMetafileCanvas.Create(m, 0);
  mc.Draw(0, 0, b);
  mc.Free;
  b.Free;
  m.SaveToFile('C:\SomePath\Test.emf');
  m.Free;
  Image1.Picture.LoadFromFile('C:\SomePath\Test.emf');
end;

Взято с Исходников.ru

Как поместить ComboBox в ячейку StringGrid?

Следующий пример демонстрирует всплывающий ComboBox в качестве местного редактора для компонента TStringGrid:

procedure TForm1.FormCreate(Sender: TObject);
begin
{Высоту у combobox не получится установить, поэтому мы будем}
{подгонять размер у грида под размер combobox!}
  StringGrid1.DefaultRowHeight := ComboBox1.Height;
{Скрываем combobox}
  ComboBox1.Visible := False;
end;

procedure TForm1.ComboBox1Change(Sender: TObject);
begin
{Получаем выбранный элемент из ComboBox и помещаем его в грид}
  StringGrid1.Cells[StringGrid1.Col,
                    StringGrid1.Row] :=
    ComboBox1.Items[ComboBox1.ItemIndex];
  ComboBox1.Visible := False;
  StringGrid1.SetFocus;
end;

procedure TForm1.ComboBox1Exit(Sender: TObject);
begin
{Получаем выбранный элемент из ComboBox и помещаем его в грид}
  StringGrid1.Cells[StringGrid1.Col,
                    StringGrid1.Row] :=
    ComboBox1.Items[ComboBox1.ItemIndex];
  ComboBox1.Visible := False;
  StringGrid1.SetFocus;
end;

procedure TForm1.StringGrid1SelectCell(Sender: TObject; Col,
Row: Integer;  var CanSelect: Boolean);
var
  R: TRect;
begin
  if ((Col = 3) AND
      (Row <> 0)) then begin
   {Размер и расположение combobox подгоняем под ячейку}
    R := StringGrid1.CellRect(Col, Row);
    R.Left := R.Left + StringGrid1.Left;
    R.Right := R.Right + StringGrid1.Left;
    R.Top := R.Top + StringGrid1.Top;
    R.Bottom := R.Bottom + StringGrid1.Top;
    ComboBox1.Left := R.Left + 1;
    ComboBox1.Top := R.Top + 1;
    ComboBox1.Width := (R.Right + 1) - R.Left;
    ComboBox1.Height := (R.Bottom + 1) - R.Top;
   {Показываем combobox}
    ComboBox1.Visible := True;
    ComboBox1.SetFocus;
  end;
  CanSelect := True;
end;

Взято с Исходников.ru

Как поместить данные в RichEdit контрол?

unit dbrich;
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, DB, DBTables, Menus, ExtCtrls, Mask, Buttons, DBCtrls;

//Замечание: вызывать Tablex.Edit необходимо перед изменением свойства paragraph

type
  TDBRichEdit = class(TRichEdit)
  private
    FDataLink: TFieldDataLink;
    FAutoDisplay: Boolean;
    FFocused: Boolean;
    FMemoLoaded: Boolean;
    FPaintControl: TPaintControl;
    procedure DataChange(Sender: TObject);
    procedure EditingChange(Sender: TObject);
    function  GetDataField: string;
    function  GetDataSource: TDataSource;
    function  GetField: TField;
    function  GetReadOnly: Boolean;
    procedure SetDataField(const Value: string);
    procedure SetDataSource(Value: TDataSource);
    procedure SetReadOnly(Value: Boolean);
    procedure SetAutoDisplay(Value: Boolean);
    procedure SetFocused(Value: Boolean);
    procedure UpdateData(Sender: TObject);
    procedure WMCut(var Message: TMessage); message WM_CUT;
    procedure WMPaste(var Message: TMessage); message WM_PASTE;
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
    procedure WMLButtonDblClk(var Message: TWMLButtonDblClk);
      message WM_LBUTTONDBLCLK;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  protected
    procedure Change; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
    procedure WndProc(var Message: TMessage); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure  LoadMemo;
    property   Field: TField read GetField;
  published
    property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay
      default True;
    property DataField: string read GetDataField write SetDataField;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property ReadOnly: Boolean read GetReadOnly write SetReadOnly
      default False;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Data Controls', [TDBRichEdit]);
end;

{Mostly copied from DBMemo}

constructor TDBRichEdit.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  inherited ReadOnly := True;
  FAutoDisplay := True;
  FDataLink := TFieldDataLink.Create;
  FDataLink.Control := Self;
  FDataLink.OnDataChange := DataChange;
  FDataLink.OnEditingChange := EditingChange;
  FDataLink.OnUpdateData := UpdateData;
  FPaintControl := TPaintControl.Create(Self, 'EDIT');
end;

destructor TDBRichEdit.Destroy;
begin
  FPaintControl.Free;
  FDataLink.Free;
  FDataLink := nil;
  inherited Destroy;
end;

procedure TDBRichEdit.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (FDataLink <> nil) and
    (AComponent = DataSource) then DataSource := nil;
end;

procedure TDBRichEdit.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited KeyDown(Key, Shift);
  if FMemoLoaded then
  begin
    if (Key = VK_DELETE) or ((Key = VK_INSERT) and (ssShift in Shift)) then
      FDataLink.Edit;
  end else
    Key := 0;
end;

procedure TDBRichEdit.KeyPress(var Key: Char);
begin
  inherited KeyPress(Key);
  if FMemoLoaded then
  begin
    if (Key in [#32..#255]) and (FDataLink.Field <> nil) and
      not FDataLink.Field.IsValidChar(Key) then
    begin
      MessageBeep(0);
      Key := #0;
    end;
    case Key of
      ^H, ^I, ^J, ^M, ^V, ^X, #32..#255:
        FDataLink.Edit;
      #27:
        FDataLink.Reset;
    end;
  end else
  begin
    if Key = #13 then LoadMemo;
    Key := #0;
  end;
end;

procedure TDBRichEdit.Change;
begin
  with FdataLink do
  begin
    {if Assigned(FdataLink) and (Assigned(DataSource))and
     (DataSource.State = dsBrowse) then
      Edit; } {make sure edits on Attributes change}
    if FMemoLoaded then Modified;
  end;
  FMemoLoaded := True;
  inherited Change;
end;

function TDBRichEdit.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

procedure TDBRichEdit.SetDataSource(Value: TDataSource);
begin
  FDataLink.DataSource := Value;
  if Value <> nil then Value.FreeNotification(Self);
end;

function TDBRichEdit.GetDataField: string;
begin
  Result := FDataLink.FieldName;
end;

procedure TDBRichEdit.SetDataField(const Value: string);
begin
  FDataLink.FieldName := Value;
end;

function TDBRichEdit.GetReadOnly: Boolean;
begin
  Result := FDataLink.ReadOnly;
end;

Взято с Исходников.ru

Как поместить иконку в окошко подсказки?

Следующий код помещает главную иконку приложения в окошки подсказок:

unit HintX;

interface

uses
  Windows, Messages, Controls;

type
  TIconHintX = class(THintWindow)
  protected
    procedure Paint; override;
  public
    function CalcHintRect(MaxWidth: Integer; const AHint: string; AData: Pointer): TRect; override;
  end;

implementation

uses Forms;

{ TIconHintX }

{-Вычисляем новый размер окошка подсказки для помещения в него иконки:-}
function TIconHintX.CalcHintRect(MaxWidth: Integer; const AHint: string;
  AData: Pointer): TRect;
begin
  Result := inherited CalcHintRect(MaxWidth, AHint, AData);       Result.Right := (Length(AHint) * 5) + Application.Icon.Width;
  Result.Bottom := (Application.Icon.Height) * 2;
end;

procedure TIconHintX.Paint;
const
  MARGIN = 5;
begin
  inherited;
  Canvas.Draw(MARGIN, MARGIN * 5, Application.Icon);
  SendMessage(Handle, WM_NCPAINT, 0, 0); //рисуем рамку окошка подсказки
end;

initialization
  //связываем наш новый класс с классом окошка подсказки установленным поумолчанию:
  HintWindowClass := TIconHintX;

end.

Чтобы увидеть это в действии, всё, что надо сделать, это поместить этот юнит список USES Вашего приложения

Взято с Исходников.ru

Как поместить JPEG-картинку в exe-файл и потом загрузить ее?

1)Создайте текстовый файл с расширением ".rc".Имя этого файла должно отличаться
от имени файла - пректа или любого модуля проекта.
Файл должен содержать строку вроде: MYJPEG JPEG C: \DownLoad\MY.JPG
где:
"MYJPEG" имя ресурса
"JPEG" пользовательский тип ресурса
"C: \DownLoad\MY.JPG" руть к JPEG файлу.

Пусть например rc - файл называется "foo.rc"

Запустите BRCC32.exe(Borland Resource CommandLine Compiler) - программа находится
в каталоге Bin Delphi / C + +Builder'а - передав ей в качестве параметра полный путь
к rc - файлу.
В нашем примере:

C: \DelphiPath\BIN\BRCC32.EXE C: \ProjectPath\FOO.RC
Вы получите откомпилированный ресурс - файл с расширением ".res".
(в нашем случает foo.res).
Далее добавте ресурс к своему приложению.

{Грузим ресурс}
{$R FOO.RES}

uses Jpeg;

procedure LoadJPEGFromRes(TheJPEG: string; ThePicture: TPicture);
var
  ResHandle: THandle;
  MemHandle: THandle;
  MemStream: TMemoryStream;
  ResPtr: PByte;
  ResSize: Longint;
  JPEGImage: TJPEGImage;
begin
  ResHandle := FindResource(hInstance, PChar(TheJPEG), 'JPEG');
  MemHandle := LoadResource(hInstance, ResHandle);
  ResPtr := LockResource(MemHandle);
  MemStream := TMemoryStream.Create;
  JPEGImage := TJPEGImage.Create;
  ResSize := SizeOfResource(hInstance, ResHandle);
  MemStream.SetSize(ResSize);
  MemStream.Write(ResPtr^, ResSize);
  FreeResource(MemHandle);
  MemStream.Seek(0, 0);
  JPEGImage.LoadFromStream(MemStream);
  ThePicture.Assign(JPEGImage);
  JPEGImage.Free;
  MemStream.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  LoadJPEGFromRes('MYJPEG', Image1.Picture);
end;

Как поместить картинки в Combo Box?

Автор: Allan Carlton

Делается это при помощи стиля ownerdraw, который присутствует в TComboBox. Нас интересуют два свойства этого стиля:

csOwnerDrawFixed - используется, если все битмапы имеют одинаковую высоту
csOwnerDrawVariable - используется для битмапов с разной высотой
После того как стиль будет установлен на один из вышеперечисленных, то можно воспользоваться событием onDrawItem. Это событие возникает каждый раз, когда приложению необходимо нарисовать пункт в выпадающем списке (combo box). Событие определяется следующим образом:

procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState)

Если выпадающему списку был присвоен стиль csOwnerDrawFixed, то всё, что надо сделать, это написать процедуру, которая будет рисовать битмап и текст в событии onDrawItem.

Для выпадающего списка со стилем csOwnerDrawVariable необходимо пройти ещё одну дополнительную стадию. Заключается эта стадия в создании обработчика для события onMeasureItem. Это событие вызывается перед DrawItem, для того, чтобы Вы могли установить фактическую высоту для каждого элемента списка. Вот его определение:

procedure TForm1.ComboBox1MeasureItem(Control: TWinControl; Index: Integer;
var Height: Integer);

Создайте новое приложение
Разместите на форме combobox и imagelist (если Вы используете delphi 1, то Вам прийдётся хранить битмапы каким-то другим способом)

procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index:Integer;  Rect: TRect; State: TOwnerDrawState);
begin
  (* Заполняем прямоугольник *)
  combobox1.canvas.fillrect(rect);

  (* Рисуем сам битмап *)
  imagelist1.Draw(comboBox1.Canvas,rect.left,rect.top,Index);

  (* Пишем текст после картинки *)
  combobox1.canvas.textout(rect.left+imagelist1.width+2,rect.top,
                          combobox1.items[index]);
end;

Взято с Исходников.ru

Как поместить картинку из базы данных, например MsSQL, в компонент TIMAGE ?

) Предполагается, что поле BLOB (например, Pict)
2) в запросе Query.SQL пишется что-то вроде
'select Pict from sometable where somefield=somevalue'
3) запрос открывается
4) делается "присваивание":
Image1.Picture.Assing(TBlobField(Query.FieldByName('Pict'))
или, если известно, что эта картинка - Bitmap, то можно
Image1.Picture.Bitmap.Assing(TBlobField(Query.FieldByName('Pict'))

А можно воспользоваться компонентом TDBImage.

Зайцев О.В.
Владимиров А.М.
Взято с Исходников.ru

Как поместить картинку в заголовок TListView?

Иногда бывает полезно в заголовке колонки показывать стрелочку, чтобы информировать пользователя, по какой колонке идёт сортировка. Добавьте следующий код в форму:

procedure TForm1.SetColumnImage( List: TListView; Column, Image: Integer;
                                 ShowImage: Boolean);
var
  Align,hHeader: integer;
  HD: HD_ITEM;

begin
  hHeader := SendMessage(List.Handle, LVM_GETHEADER, 0, 0);
  with HD do
  begin
    case List.Columns[Column].Alignment of
      taLeftJustify:  Align := HDF_LEFT;
      taCenter:       Align := HDF_CENTER;
      taRightJustify: Align := HDF_RIGHT;
    else
      Align := HDF_LEFT;
    end;

    mask := HDI_IMAGE or HDI_FORMAT;

    pszText := PChar(List.Columns[Column].Caption);

    if ShowImage then
      fmt := HDF_STRING or HDF_IMAGE or HDF_BITMAP_ON_RIGHT
    else
      fmt := HDF_STRING or Align;

    iImage := Image;
  end;
  SendMessage(hHeader, HDM_SETITEM, Column, Integer(@HD));
end;

Картинки берутся из списка SmallImages. Вам надо будет вызвать эту функцию для каждой колонки и установить ShowImage в TRUE для той колонки, которую Вы будете сортировать. Сделать это можно в функции OnColumnClick():

procedure TForm1.ListView1ColumnClick(Sender: TObject;
  Column: TListColumn);
var
  i : integer;
begin
  // Это Ваша собственная функция сортировки
  CustomSort( @CustomSortProc, Column.Index );
  // Этот цикл отображает иконку в выбранной колонке.
  for i := 0 to ListView1.Columns.Count-1 do
    SetColumnImage( ListView1, i, 0, i = Column.Index );
end;

Проблема: Изменение размера колонки генерирует сообщение WM_PAINT, которое стирает картинку, поэтому Вам прийдётся переопределить WM_PAINT и вызвать SetColumnImage снова.

Использовался компонент TApplicationEvents в delphi 5.

Взято с Исходников.ru

Как поместить курсор мышки в нужное место на форме?

uses
  Windows;

procedure PlaceMyMouse(Sender: TForm; X, Y: word);
var
  MyPoint: TPoint;
begin
  MyPoint := Sender.ClientToScreen(Point(X, Y));
  SetCursorPos(MyPoint.X, MyPoint.Y);
end;

Взято с Исходников.ru

Как поместить маленькие битмапы в TPopUpMenu?

Следующий пример демонстрирует добавление битмапа в пункт PopUpMenu при помощи API функции SetMenuItemBitmaps(). Эта функция имеет следующие параметры: дескриптор всплывающего меню, номер (начиная с нуля) пункта меню в который мы хотим добаить битмап, и два дескриптора битмапов (одна картинка для меню в активном состоянии, а вторая для неактивного состояния).

type
  TForm1 = class(TForm)
    PopupMenu1: TPopupMenu;
    Pop11: TMenuItem;
    Pop21: TMenuItem;
    Pop31: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
    bmUnChecked : TBitmap;
    bmChecked : TBitmap;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormCreate(Sender: TObject);
begin
  bmUnChecked := TBitmap.Create;
  bmUnChecked.LoadFromFile(
    'C:\Program Files\Borland\BitBtns\ALARMRNG.BMP');
  bmChecked := TBitmap.Create;
  bmChecked.LoadFromFile(
    'C:\Program Files\Borland\BitBtns\CHECK.BMP');
{Добавляем битмапы в пункт меню начиная с 1 в PopUpMenu}
  SetMenuItemBitmaps(PopUpMenu1.Handle,
                     1,
                     MF_BYPOSITION,
                     BmUnChecked.Handle,
                     BmChecked.Handle);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  bmUnChecked.Free;
  bmChecked.Free;
end;

procedure TForm1.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
  pt : TPoint;
begin
  pt := ClientToScreen(Point(x, y));
  PopUpMenu1.Popup(pt.x, pt.y);
end;

Взято с Исходников.ru

Как поместить окно програмы поверх всех?

Если навсегда - то поставить у формы FormStyle свойство в fsStayonTop,
если надо чтобы просто программа была установлена в активное состояние (как будто кликнули на ней на таскбаре) - Application.BringtoFront

Кроме того можно играться API функцией ShowWindow передавая ей Form1.Handle, или Application.Handle и один из кучи параметров - посмотри на нее Help - там много вариантов.

Автор ответа: Vit
Взято с Vingrad.ru

Как поместить приложение в автозапуск Windows?

Для этого надо добавить ключ в реестр:

procedure SetAutorun(aProgTitle,aCmdLine: string; aRunOnce: boolean );
var
  hKey: string;
  hReg: TRegIniFile;
begin
  if aRunOnce then hKey := 'Once'
  else
    hKey := '';

  hReg := TRegIniFile.Create( '' );
  hReg.RootKey := HKEY_LOCAL_MACHINE;
  hReg.WriteString('Software\Microsoft\Windows\CurrentVersion\Run'
                  + hKey + #0,
                  aProgTitle,
                  aCmdLine );
  hReg.destroy;
end;

Взято с Исходников.ru

Как поместить ProgressBar в панель StatusBar?

Корректнее было бы самому канву рисовать, но можно и просто вставить - держи функцию для этого - применять вместо стандартного метода Create.

FunctionCreateProgressBar(StatusBar:TStatusBar; index:integer):TProgressBar;
  var findleft:integer;
      i:integer;
begin
result:=TProgressBar.create(Statusbar);
result.parent:=Statusbar;
result.visible:=true;
result.top:=2;
findleft:=0;
for i:=0 to index-1 do
  findleft:=findleft+Statusbar.Panels[i].width+1;
result.left:=findleft;
result.width:=Statusbar.Panels[index].width-4;
result.height:=Statusbar.height-2;
end;

Автор ответа: Vit
Взято с Vingrad.ru

Есть два принципиально разных решения. Первый вариант - это сделать все " вручную" .

Здесь создается Bitmap с текстом (возможно любое изображение). Чтобы нарисовать светлую часть полосы, достаточно скопировать кусок Bitmap на StatusBar, а чтобы нарисовать темную часть полосы, нужно скопировать кусок Bitmap с инвертированием. При этом фон станет темным, а текст светлым. Реализация ясна из самой программы.

Второй вариант более простой в реализации, но и менее функциональный. StatusBar является наследником TWinControl, а следовательно, на нем можно разместить еще какие-то компоненты. Но сделать это можно только динамически (непосредственно из программы). На StatusBar помещается компонент ProgressBar, вначале невидимый. Когда в нем появляется необходимость, его нужно сделать видимым и начать изменять свойство Position.

Из этого примера хорошо видны некоторые достоинства и недостатки объектов.
Если у Вас Delphi3, то строчка pb.Smooth := true; работать не будет. На сайте выложена версия программы с заменой этой строчки. Впрочем, ее можно просто удалить - принципиально это ничего не изменит. Скачать все необходимые для компиляции файлы проекта можно на program.dax.ru.

Способ 1

uses Commctrl;
const
MaxProgress = 50;
var
bm: TBitmap;
// Возвращает прямоугольник нулевой панели:
function GetPanelRect: TRect;
begin
SendMessage(Form1.StatusBar1.Handle, SB_GETRECT, 0,
   integer(@result));
InflateRect(result, -1, -1);
end;

// Копирует часть bm на StatusBar
procedure CopyPart(left, right: integer; ACopyMode: TCopyMode);
var bmRect, pnRect: TRect;
begin
bmRect := Rect(left, 0, right, bm.Height - 1);
pnRect := bmRect;
with GetPanelRect do
   OffsetRect(pnRect, Left, Top);
with Form1.StatusBar1.Canvas do begin
   CopyMode := ACopyMode;
   CopyRect(pnRect, bm.Canvas, bmRect);
end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
with StatusBar1.Panels.Add do begin
   Width := 100;
   Style := psOwnerDraw;
end;
with StatusBar1.Panels.Add do begin
   Width := 0;
   Text := 'abc';
end;
Timer1.Enabled := false;
Timer1.Interval := 50;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Timer1.Enabled := true;
bm := TBitmap.Create;
with GetPanelRect do begin
   bm.Width := Right - Left;
   bm.Height := Bottom - Top;
end;
with bm.Canvas do begin
   Brush.Color := clSilver;
   FillRect(Bounds(0, 0, bm.Width, bm.Height));
   TextOut(1, 1, 'Doing smth...');
end;
CopyPart(0, bm.Width - 1, cmSrcCopy); // Вывод текста
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Tag := Timer1.Tag + 1;
if Timer1.Tag >  MaxProgress then begin
   Timer1.Enabled := false;
   Timer1.Tag := 0;
   StatusBar1.Repaint; // Очистка StatusBar
end else
   // Вывод только что закрашенной части:
   CopyPart(trunc((Timer1.Tag - 1) / MaxProgress * bm.Width),
     trunc(Timer1.Tag / MaxProgress * bm.Width), cmNotSrcCopy);
end;

procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
Panel: TStatusPanel; const Rect: TRect);
var p: integer;
begin
if (Panel.Index = 0) and (Timer1.Tag >  0) then begin
   p := round((Rect.Right - Rect.Left) * Timer1.Tag / MaxProgress);
   // Вывод закрашенной части:
   CopyPart(0, p, cmNotSrcCopy);
   // Вывод незакрашенной части:
   CopyPart(p + 1, bm.Width - 1, cmSrcCopy);
end;
end;

Способ 2

uses Commctrl;
const
MaxProgress = 50;
var pb: TProgressBar;

function GetPanelRect: TRect;
begin
SendMessage(Form1.StatusBar1.Handle, SB_GETRECT, 0, integer(@result));
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
with StatusBar1.Panels.Add do begin
   Width := 100;
   Style := psOwnerDraw;
end;
with StatusBar1.Panels.Add do begin
   Width := 0;
   Text := 'abc';
end;
Timer1.Enabled := false;
Timer1.Interval := 50;
pb := TProgressBar.Create(StatusBar1);
pb.Visible := false;
pb.Parent := StatusBar1;
pb.BoundsRect := GetPanelRect;
pb.Smooth := true;
pb.Step := 1;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Timer1.Enabled := true;
pb.Position := 0;
pb.Max := MaxProgress;
pb.Visible := true;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
Timer1.Tag := Timer1.Tag + 1;
if Timer1.Tag >  MaxProgress then begin
   Timer1.Enabled := false;
   Timer1.Tag := 0;
   pb.Visible := false;
end else pb.StepIt;
end;

Все советы и замечания, пожалуйста, присылайте на subscribe@program.dax.ru
Даниил Карапетян.

Автор:

StayAtHome

Взято из

Как поместить прозрачную фоновую каринку на компонент CoolBar?

procedure TForm1.Button1Click(Sender: TObject);
var
  Bm1: TBitmap;
  Bm2: TBitmap;
begin
  Bm1 := TBitmap.Create;
  Bm2 := TBitmap.Create;
  Bm1.LoadFromFile('c:\download\test.bmp');
  Bm2.Width := Bm1.Width;
  Bm2.Height := Bm1.Height;
  bm2.Canvas.Brush.Color := CoolBar1.Color;
  bm2.Canvas.BrushCopy(Rect(0, 0, bm2.Width, bm2.Height), Bm1,
    Rect(0, 0, Bm1.width, Bm1.Height), ClWhite);
  bm1.Free;
  CoolBar1.Bitmap.Assign(bm2);
  bm2.Free;
end;

Как поместить прозрачный текст на Canvas TBitmap

Автор: Олег Кулабухов

procedureTForm1.Button1Click(Sender: TObject);
var
  OldBkMode: integer;
begin
  Image1.Picture.Bitmap.Canvas.Font.Color := clBlue;
  OldBkMode := SetBkMode(Image1.Picture.Bitmap.Canvas.Handle, TRANSPARENT);
  Image1.Picture.Bitmap.Canvas.TextOut(10, 10, 'Hello');
  SetBkMode(Image1.Picture.Bitmap.Canvas.Handle, OldBkMode);
end;

Взято из

Как поместить TCheckBox внутри TRichEdit?

Для использования следующего примера, необходимо создать новую форму, перетащить на неё TRichEdit (RichEdit1) и создать checkbox (acb) в событии FormCreate().

procedure TForm1.FormCreate(Sender: TObject);
var
  Acb: TCheckBox;
begin
  RichEdit1.Left := 20;
  Acb := TCheckBox.Create(RichEdit1);
  Acb.Left := 30;
  Acb.Top := 30;
  Acb.Caption := 'my checkbox';
  Acb.Parent := RichEdit1;
end;

Взято с Исходников.ru

Как поместить TMenuItem справа у формы?

Допустим, у Вас есть TMainMenu MainMenu1 и HelpMenuItem в конце панели меню (Menubar). Если Вызвать следующий обработчик события OnCreate, то HelpMenuItem сместится вправо.

uses
  Windows;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ModifyMenu(MainMenu1.Handle, 0, mf_ByPosition or mf_Popup
             or mf_Help, HelpMenuItem1.Handle, '&Help');
end;

Взято с Исходников.ru

Как поместить в буфер файл с помощью File Mapping?

1.
В файлике Delphi5\Demos\Resxplor\exeimage.pas ищи слово CreateFileMapping
2.
идея простая открываешь файл .. (или создаешь)
создаешь Mapping ... CreateFileMapping
отображаешь Mapping в свой процесс MapViewOfFile
и всё

var
  SharedHandle: THandle;
  FileView: Pointer;
  MyFile: HFILE;
begin
  MyFile := OpenFile('c:\1.txt', // pointer to filename
    ..., // pointer to buffer for file information
    ... // action and attributes
    );
  SharedHandle := CreateFileMapping(MyFile, nil, PAGE_READWRITE, 0,
    size {размер файла}, PChar('MyFile'));
  FileView := MapViewOfFile(SharedHandle, FILE_MAP_WRITE, 0, 0, size {размер файла});
  ...
    ...
    ...
    ...
// потом
  UnmapViewOfFile(FileView);

Взято с Vingrad.ru

Как посчитать факториал?

{
  The factorial of a positive integer is defined as:

  n! = n*(n-1)*(n-2)*(n-3)*...*2*1
  1! = 1
  0! = 1

  Example: 5! = 5*4*3*2*1
}

// Iterative Solution:

function FacIterative(n: Word): Longint;
var
  f: LongInt;
  i: Integer;
begin
  f := 1;
  for i := 2 to n do f := f * i;
  Result := f;
end;

// Recursive Solution:

function FacRecursive(n: Word): LongInt;
begin
  if n > 1 then
    Result := n * FacRecursive(n-1)
  else
    Result := 1;
end;

Взято с сайта

Как посчитать возраст человека?

function CalculateAge(Birthday, CurrentDate: TDate): Integer;
var
  Month, Day, Year, CurrentYear, CurrentMonth, CurrentDay: Word;
begin
  DecodeDate(Birthday, Year, Month, Day);
  DecodeDate(CurrentDate, CurrentYear, CurrentMonth, CurrentDay);

  if (Year = CurrentYear) and (Month = CurrentMonth) and (Day = CurrentDay) then
  begin
    Result := 0;
  end
  else
  begin
    Result := CurrentYear - Year;
    if (Month > CurrentMonth) then
      Dec(Result)
    else
    begin
      if Month = CurrentMonth then
        if (Day > CurrentDay) then
          Dec(Result);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Label1.Caption := Format('Your age is %d', [CalculateAge(StrToDate('01.01.1903'), Date)]);
end;

Взято с сайта

Как послать нажатие клавиши в какое-нибудь окно?

Эта процедура посылает сообщение о нажатии клавиши.

procedure PostKeyEx32(key: Word; const shift: TShiftState; specialkey: Boolean);
type TShiftKeyInfo = record
    shift: Byte;
    vkey: Byte;
  end;
  byteset = set of 0..7;
const shiftkeys: array[1..3] of TShiftKeyInfo = ((shift: Ord(ssCtrl);
    vkey: VK_CONTROL), (shift: Ord(ssShift); vkey: VK_SHIFT), (shift: Ord(ssAlt); vkey: VK_MENU));

var flag: DWORD;
  bShift: ByteSet absolute shift;
  i: Integer;
begin
  for i := 1 to 3 do
    if shiftkeys[i].shift in bShift then keybd_event(shiftkeys[i].vkey, MapVirtualKey(shiftkeys[i].vkey, 0), 0, 0);
  if specialkey then
    flag := KEYEVENTF_EXTENDEDKEY
  else
    flag := 0;
  keybd_event(key, MapvirtualKey(key, 0), flag, 0);
  flag := flag or KEYEVENTF_KEYUP;
  keybd_event(key, MapvirtualKey(key, 0), flag, 0);
  for i := 3 downto 1 do
    if shiftkeys[i].shift in bShift then keybd_event(shiftkeys[i].vkey, MapVirtualKey(shiftkeys[i].vkey, 0), KEYEVENTF_KEYUP, 0);
end;

Чтобы воспользоваться этой процедурой надо предварительно найти и активизировать нужное окно:

SetForegroundWindow(FindWindow(PChar(WindowClassName), PChar(WindowCaption)));

PS. не забудьте поставить задержки типа Sleep(100) после активизации окна и между посылаемыми клавишами, не то окно может не успевать реагировать на клавиши...

Автор ответа: Vit
Взято с Vingrad.ru

Как послать нажатие кнопки мыши в окно?

WM_LBUTTONDOWN
WM_RBUTTONDOWN
Автор ответа: Song
Взято с Vingrad.ru

Я решил проверить точку нажатия мышки таким вот образом:
...
SetForegroundWindow(WindowUO);
mouse_event(MOUSEEVENTF_MOVE,400,400,0,0);
...
и получилось, что мышка перемещалась не в те координаты(относительно разрешения монитора (800 на 600)) которые я задумал(в не зависимости от местоположения мышки она перемещалась строго по одному направлению на одинаковое расстояние), причем я сделал еще один вариант - dx=100, dy=100, но тогда перемещение мышки произошло в другую сторону(в сторону x=0 y=0 монитора)!
Подскажите плз в чем дело?
Автор ответа: Spawn
Взято с Vingrad.ru

Mouse_event программирует не абсолюьные, а относительные координаты.
Чтобы не думалось, просто сначала установите курсор в нужную позицию - SetCursorPos(), а потом делайте клик - Mouse_event()
Автор ответа: Song
Взято с Vingrad.ru

Как послать широковещательный UDP пакет?

procedure TMainForm.FormCreate(Sender: TObject);
var Init:TWSAData;
SockOpt:BOOL;
Sock:TSocket;
Target:TSockAddrIn;
begin
WSAStartup($101,Init);
Sock:=Socket(PF_INET,SOCK_DGRAM,IPPROTO_UDP);
SockOpt:=TRUE;
SetSockOpt(Sock,SOL_SOCKET,SO_BROADCAST,PChar(@SockOpt),SizeOf(SockOpt)) ;
Target.sin_port:=htons(8167);//номер порта
Target.sin_addr.S_addr:=INADDR_BROADCAST;
Target.sa_family:=AF_INET;
SendTo(Sock,Data,DataBytes,0,Target,SizeOf(Target));
WSACleanup;
end;

Взято с Исходников.ru