Delphi - база знаний

         

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


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




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?


Как получить список папок 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?


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




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

Автор:

Vit

Взято из





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


Как получить список установленных модемов в 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?


Как получить строковый путь узла 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 страницы без фреймов?


Как получить 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 путь к файлу?


Как получить 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?


Как получить версию моей 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?


Как получить версию 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?


Как получить закэшированные пароли в 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?


Как получитьописание кода, полученного 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?


Как пользоваться командой шела - 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 страницы?


Как поменять 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 в заголовке консольного окна?


Как поменять иконку и ст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 в ячейку 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 контрол?


Как поместить данные в 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-файл и потом загрузить ее?


Как поместить 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?


Как поместить картинки в 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 ?


Как поместить картинку из базы данных, например 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?


Как поместить картинку в заголовок 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?


Как поместить маленькие битмапы в 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?


Как поместить приложение в автозапуск 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?


Как поместить 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?


Как поместить прозрачную фоновую каринку на компонент 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


Как поместить прозрачный текст на 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?


Как поместить 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 справа у формы?


Как поместить 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?


Как поместить в буфер файл с помощью 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 пакет?


Как послать широковещательный 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