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

Чтобы вывести под любым углом текст необходимо использовать TrueType Fonts (например "Arial"). Например:

var

  LogFont : TLogFont;

...
  GetObject(Canvas.Font.Handle, SizeOf(TLogFont), @LogFont);
  { Вывести текст 1/10 градуса против часовой стрелки }

  LogFont.lfEscapement := Angle*10;

  Canvas.Font.Handle := CreateFontIndirect(LogFont);

{ Эта процедура устанавливает угол вывода текста
для указанного Canvas, угол в градусах
Шрифт должен быть TrueType }
procedure CanvasSetTextAngle(c: TCanvas; d: single);
var
  LogRec: TLOGFONT; { Информация о шрифте }
begin
  {Читаем текущюю инф. о шрифте }
  GetObject(c.Font.Handle,SizeOf(LogRec) ,Addr(LogRec) );
  { Изменяем угол }
  LogRec.lfEscapement := round(d*10);
  { Устанавливаем новые параметры }
  c.Font.Handle := CreateFontIndirect(LogRec);
end;

procedure TextOutAngle(x,y,aAngle,aSize: integer; txt: string);
var
  hFont, Fontold: integer;
  DC: hdc;
  Fontname: string;
begin
  if length(txt) = 0 then
    Exit;
  DC:= Screen.ActiveForm.Canvas.handle;
  SetBkMode(DC, transparent);
  Fontname:= Screen.ActiveForm.Canvas.Font.name;
  hFont:= CreateFont(-aSize,0, aAngle*10,0, fw_normal,0, 0,
  0,1,4,$10,2,4,PChar(Fontname));
  Fontold:= SelectObject(DC, hFont);
  TextOut(DC,x,y,PChar(txt), length(txt));
  SelectObject(DC, Fontold);
  DeleteObject(hFont);
end;

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

procedure TForm1.Button1Click(Sender: TObject);
var
  logfont: TLogFont;
  font: Thandle;
  count: integer;
begin
  LogFont.lfheight := 20;
  logfont.lfwidth := 20;
  logfont.lfweight := 750;
  LogFont.lfEscapement := -200;
  logfont.lfcharset := 1;
  logfont.lfoutprecision := out_tt_precis;
  logfont.lfquality := draft_quality;
  logfont.lfpitchandfamily := FF_Modern;

  font := createfontindirect(logfont);

  SelectObject(Form1.canvas.handle, font);

  SetTextColor(Form1.canvas.handle, rgb(0, 0, 200));
  SetBKmode(Form1.canvas.handle, transparent);

  for count := 1 to 10 do
  begin
    Canvas.TextOut(Random(form1.width), Random(form1.height), 'Delphi World');
    SetTextColor(form1.canvas.handle, rgb(Random(255), Random(255), Random(255)));
  end;

  DeleteObject(font);
end;

{Create a rotated font based on the font object F}
function CreateRotatedFont(F : TFont; Angle : Integer) : hFont;
var
  LF: TLogFont;
begin
  FillChar(LF, SizeOf(LF), #0);
  with LF do
  begin
    lfHeight := F.Height;
    lfWidth := 0;
    lfEscapement := Angle*10;
    lfOrientation := 0;
    if fsBold in F.Style then
      lfWeight := FW_BOLD
    else
      lfWeight := FW_NORMAL;
    lfItalic := Byte(fsItalic in F.Style);
    lfUnderline := Byte(fsUnderline in F.Style);
    lfStrikeOut := Byte(fsStrikeOut in F.Style);
    lfCharSet := DEFAULT_CHARSET;
    StrPCopy(lfFaceName, F.name);
    lfQuality := DEFAULT_QUALITY;
    {everything else as default}
    lfOutPrecision := OUT_DEFAULT_PRECIS;
    lfClipPrecision := CLIP_DEFAULT_PRECIS;
    case F.Pitch of
      fpVariable: lfPitchAndFamily := VARIABLE_PITCH;
      fpFixed: lfPitchAndFamily := FIXED_PITCH;
      else
        lfPitchAndFamily := DEFAULT_PITCH;
    end;
  end;
  Result := CreateFontIndirect(LF);
end;

...

{create the rotated font}
if FontAngle <> 0 then
  Canvas.Font.Handle := CreateRotatedFont(Font, FontAngle);
...

Вращаются только векторные шрифты.

Взято из

Как выделить кнопку в DBNavigator программно?

type TFake=class(TDBNavigator);

procedure TForm1.Button1Click(Sender: TObject);
begin
TFake(DBNavigator1).buttons[nbNext].Perform(WM_RBUTTONDOWN,0,0);
TFake(DBNavigator1).buttons[nbNext].Perform(WM_RBUTTONUP,0,0);
end;

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

Как выдвинуть дверцу CD-ROM?

mciSendString('Set cdaudio Door Open Wait', nil, 0, handle);
mciSendCommand(mp.DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);

Взято с сайта

Как выяснить дату последнего изменения файла?

function GetFileDate(FileName: string): string;
  var FHandle: Integer;
begin
  FHandle := FileOpen(FileName, 0);
try
  Result := DateTimeToStr(FileDateToDateTime(FileGetDate(FHandle)));
finally
  FileClose(FHandle);
end;
end;

Взято с сайта

Как выяснить имеет ли объект определённое свойство?

functionhasprop(comp: TComponent; const prop: String): Boolean;
var
  proplist: PPropList;
  numprops, i: Integer;
begin
  result := false;
  getmem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer));
  try
    NumProps := getproplist(comp.classInfo, tkProperties, proplist);
    for i := 0 to pred (NumProps) do
    begin
      if comparetext(proplist[i]^.Name, prop) = 0 then
      begin
        result := true;
        break;
      end;
    end;
  finally
    freemem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer));
  end;
end;

procedure setcomppropstring(comp: TComponent; const prop, s: String);
var
  proplist: PPropList;
  numprops, i: Integer;
begin
  getmem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer));
  try
    NumProps := getproplist(comp.classInfo, tkProperties, proplist);
    for i := 0 to pred (NumProps) do
    begin
      if (comparetext(proplist[i]^.Name, prop) = 0) and
         (comparetext(proplist[i]^.proptype^.name, 'string') = 0 then
      begin
        setStrProp(comp, proplist[i], s);
        break;
      end;
    end;
  finally
    freemem(proplist, getTypeData(comp.classinfo)^.propcount * Sizeof(Pointer));
  end;
end;

Взято из

function HasProperty(Obj: TObject; Prop: string): PPropInfo;
begin
  Result := GetPropInfo(Obj.ClassInfo, Prop);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  p: pointer;
begin
  p := HasProperty(Button1, 'Color');
  if p <> nil then
    SetOrdProp(Button1, p, clRed)
  else
    ShowMessage('Button has no color property');
  p := HasProperty(Label1, 'Color');
  if p <> nil then
    SetOrdProp(Label1, p, clRed)
  else
    ShowMessage('Label has no color property');
  p := HasProperty(Label1.Font, 'Color');
  if p <> nil then
    SetOrdProp(Label1.Font.Color, p, clBlue)
  else
    ShowMessage('Label.Font has no color property');
end;

Как выяснить номер версии Oracle?

This function gets the connected Oracle version. It returns the version info in 3 OUT parameters.

VerNum         : double    eg. 7.23
   VerStrShort    : string       eg. '7.2.3.0.0'
   VerStrLong    : string       eg. 'Oracle7 Server Release 7.2.3.0.0 - Production Release'

I have tested it with Oracle 7.2 and 8.17. I assume it should work for the others (not too sure about Oracle 9 though). Any feedback and fixes for different versions would be appreciated.

The TQuery parameter that it recieves is a TQuery component that is connected to an open database connection.

Example :

var
  VNum: double;
  VShort: string;
  VLong: string;
begin
  GetOraVersion(MySql, VNum, VShort, VLong);
  Label1.Caption := FloatToStr(VNum);
  Label2.Caption := VShort;
  Label3.Caption := VLong;
end;

procedure GetOraVersion(Query: TQuery;
                                   out VerNum: double;
                                   out VerStrShort: string;
                                   out VerStrLong: string);
var
  sTmp: string;
  cKey: char;
  i: integer;
begin
  Query.SQL.Text := 'select banner from v$version ' +
                             'where banner like ' + QuotedStr('Oracle%');
  Query.Open;

  if not Query.Eof then
    VerStrLong := Query.Fields[0].AsString
  else
  begin
    // Don't know this version
    VerStrLong := '?';
    VerNum := 0.0;
    VerStrShort := '?.?.?.?';
  end;

  Query.Close;

  if VerStrLong <> '?' then
  begin
    cKey := VerStrLong[7]; // eg. Oracle7 or Oracle8i
    VerStrLong[7] := 'X'; // Mask it out
    sTmp := copy(VerStrLong, pos(cKey, VerStrLong), 1024);
    VerStrShort := copy(sTmp, 1, pos(' ', sTmp) - 1);
    sTmp := copy(VerStrShort, 1, pos('.', VerStrShort));

    for i := length(sTmp) + 1 to length(VerStrShort) do
    begin
      if VerStrShort[i] <> '.' then
        sTmp := sTmp + VerStrShort[i];
    end;

    VerNum := StrToFloat(sTmp);
    VerStrLong[7] := cKey; // Put correct character back
  end;
end;

Взято с

Delphi Knowledge Base

Как выключить компьютер с любой версией Windows?

function GetWinVersion: String;
var
   VersionInfo : TOSVersionInfo;
   OSName      : String;
begin
   // устанавливаем размер записи
   VersionInfo.dwOSVersionInfoSize := SizeOf( TOSVersionInfo );

   if Windows.GetVersionEx( VersionInfo ) then
      begin
         with VersionInfo do
         begin
            case dwPlatformId of
               VER_PLATFORM_WIN32s   : OSName := 'Win32s';
               VER_PLATFORM_WIN32_WINDOWS : OSName := 'Windows 95';
               VER_PLATFORM_WIN32_NT      : OSName := 'Windows NT';
            end; // case dwPlatformId
            Result := OSName + ' Version ' + IntToStr( dwMajorVersion ) + '.' + IntToStr( dwMinorVersion ) +
                      #13#10' (Build ' + IntToStr( dwBuildNumber ) + ': ' + szCSDVersion + ')';
         end; // with VersionInfo
      end // if GetVersionEx
   else
      Result := '';
end;

procedure ShutDown;
const
  SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';   // Borland forgot this declaration
var
  hToken       : THandle;
  tkp          : TTokenPrivileges;
  tkpo         : TTokenPrivileges;
  zero         : DWORD;
begin
  if Pos( 'Windows NT', GetWinVersion) = 1  then // we've got to do a whole buch of things
     begin
        zero := 0;
        if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
           begin
             MessageBox( 0, 'Exit Error', 'OpenProcessToken() Failed', MB_OK );
             Exit;
           end; // if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken)
        if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
           begin
             MessageBox( 0, 'Exit Error', 'OpenProcessToken() Failed', MB_OK );
             Exit;
           end; // if not OpenProcessToken( GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken)

        // SE_SHUTDOWN_NAME
        if not LookupPrivilegeValue( nil, 'SeShutdownPrivilege' , tkp.Privileges[ 0 ].Luid ) then
           begin
              MessageBox( 0, 'Exit Error', 'LookupPrivilegeValue() Failed', MB_OK );
              Exit;
           end; // if not LookupPrivilegeValue( nil, 'SeShutdownPrivilege' , tkp.Privileges[0].Luid )
        tkp.PrivilegeCount := 1;
        tkp.Privileges[ 0 ].Attributes := SE_PRIVILEGE_ENABLED;

        AdjustTokenPrivileges( hToken, False, tkp, SizeOf( TTokenPrivileges ), tkpo, zero );
        if Boolean( GetLastError() ) then
           begin
              MessageBox( 0, 'Exit Error', 'AdjustTokenPrivileges() Failed', MB_OK );
              Exit;
           end // if Boolean( GetLastError() )
        else
           ExitWindowsEx( EWX_FORCE or EWX_SHUTDOWN, 0 );
      end // if OSVersion = 'Windows NT'
   else
      begin // just shut the machine down
        ExitWindowsEx( EWX_FORCE or EWX_SHUTDOWN, 0 );
      end; // else
end;

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

ExitWindowsEx(EWX_FORCE,0);

или

Запуск из коммандной строки

rundll32 krnl386.exe,exitkernel

только под XP все это работает плохо. Надо думать...
Автор ответа: Vit
Взято с Vingrad.ru

exitkernel очень радикальный способ потому что не сохраняются настройки рабочего стола, ini файлы и другие установки, зато быстро

Есть способ намного лучше: ф-ия SHExitWindowsEx из shell32.dll
С неё всё good. Это запуск из-под WinExec()
Программно же только с получением привелегии.
Замечу также что флаг EWX_FORCE необходим только для принудительного завершения при выдаче каких либо сообщений или модальных окон, что воспрепятствует завершению, например, "К компьютеру подключены пользователи. Данные могут быть утярены. Вы хотите завершить работу?" или сообщение, которое автор указал в вопросе.
Если нет таких сообщений EWX_FORCE не обязателен. Также есть отдельные флаги для выключение компьютера (по умолчанию - перезагрузка) или завершения сетевого сеанса.

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

Как выключить, перезагрузить или завершить Windows?

{1.}

functionMyExitWindows(RebootParam: Longword): Boolean;
var
  TTokenHd: THandle;
  TTokenPvg: TTokenPrivileges;
  cbtpPrevious: DWORD;
  rTTokenPvg: TTokenPrivileges;
  pcbtpPreviousRequired: DWORD;
  tpResult: Boolean;
const
  SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
begin
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    tpResult := OpenProcessToken(GetCurrentProcess(),
      TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
      TTokenHd);
    if tpResult then
    begin
      tpResult := LookupPrivilegeValue(nil,
                                       SE_SHUTDOWN_NAME,
                                       TTokenPvg.Privileges[0].Luid);
      TTokenPvg.PrivilegeCount := 1;
      TTokenPvg.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
      cbtpPrevious := SizeOf(rTTokenPvg);
      pcbtpPreviousRequired := 0;
      if tpResult then
        Windows.AdjustTokenPrivileges(TTokenHd,
                                      False,
                                      TTokenPvg,
                                      cbtpPrevious,
                                      rTTokenPvg,
                                      pcbtpPreviousRequired);
    end;
  end;
  Result := ExitWindowsEx(RebootParam, 0);
end;

// Example to shutdown Windows:

procedure TForm1.Button1Click(Sender: TObject);
begin
  MyExitWindows(EWX_POWEROFF or EWX_FORCE);
end;

// Example to reboot Windows:

procedure TForm1.Button1Click(Sender: TObject);
begin
  MyExitWindows(EWX_REBOOT or EWX_FORCE);
end;

// Parameters for MyExitWindows()

{************************************************************************}

{2. Console Shutdown Demo}

program Shutdown;
{$APPTYPE CONSOLE}

uses
  SysUtils,
  Windows;

// Shutdown Program
// (c) 2000 NeuralAbyss Software
// www.neuralabyss.com

var
  logoff: Boolean = False;
  reboot: Boolean = False;
  warn: Boolean = False;
  downQuick: Boolean = False;
  cancelShutdown: Boolean = False;
  powerOff: Boolean = False;
  timeDelay: Integer = 0;

function HasParam(Opt: Char): Boolean;
var
  x: Integer;
begin
  Result := False;
  for x := 1 to ParamCount do
    if (ParamStr(x) = '-' + opt) or (ParamStr(x) = '/' + opt) then Result := True;
end;

function GetErrorstring: string;
var
  lz: Cardinal;
  err: array[0..512] of Char;
begin
  lz := GetLastError;
  FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, lz, 0, @err, 512, nil);
  Result := string(err);
end;

procedure DoShutdown;
var
  rl, flgs: Cardinal;
  hToken: Cardinal;
  tkp: TOKEN_PRIVILEGES;
begin
  flgs := 0;
  if downQuick then flgs := flgs or EWX_FORCE;
  if not reboot then flgs := flgs or EWX_SHUTDOWN;
  if reboot then flgs := flgs or EWX_REBOOT;
  if poweroff and (not reboot) then flgs := flgs or EWX_POWEROFF;
  if logoff then flgs := (flgs and (not (EWX_REBOOT or EWX_SHUTDOWN or EWX_POWEROFF))) or
      EWX_LOGOFF;
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    if not OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,
      hToken) then
      Writeln('Cannot open process token. [' + GetErrorstring + ']')
    else
    begin
      if LookupPrivilegeValue(nil, 'SeShutdownPrivilege', tkp.Privileges[0].Luid) then
      begin
        tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
        tkp.PrivilegeCount           := 1;
        AdjustTokenPrivileges(hToken, False, tkp, 0, nil, rl);
        if GetLastError <> ERROR_SUCCESS then
          Writeln('Error adjusting process privileges.');
      end
      else
        Writeln('Cannot find privilege value. [' + GetErrorstring + ']');
    end;
    {   if CancelShutdown then
          if AbortSystemShutdown(nil) = False then
            Writeln(\'Cannot abort. [\' + GetErrorstring + \']\')
          else
           Writeln(\'Cancelled.\')
       else
       begin
         if InitiateSystemShutdown(nil, nil, timeDelay, downQuick, Reboot) = False then
            Writeln(\'Cannot go down. [\' + GetErrorstring + \']\')
         else
            Writeln(\'Shutting down!\');
       end;
    }
  end;
  //     else begin
  ExitWindowsEx(flgs, 0);
  //     end;
end;

begin
  Writeln('Shutdown v0.3 for Win32 (similar to the Linux version)');
  Writeln('(c) 2000 NeuralAbyss Software. All Rights Reserved.');
  if HasParam('?') or (ParamCount = 0) then
  begin
    Writeln('Usage:    shutdown [-akrhfnc] [-t secs]');
    Writeln('                  -k:      do not really shutdown, only warn.');
    Writeln('                  -r:      reboot after shutdown.');
    Writeln('                  -h:      halt after shutdown.');
    Writeln('                  -p:      power off after shutdown');
    Writeln('                  -l:      log off only');
    Writeln('                  -n:      kill apps that do not want to die.');
    Writeln('                  -c:      cancel a running shutdown.');
  end
  else
  begin
    if HasParam('k') then warn := True;
    if HasParam('r') then reboot := True;
    if HasParam('h') and reboot then
    begin
      Writeln('Error: Cannot specify -r and -h parameters together!');
      Exit;
    end;
    if HasParam('h') then reboot := False;
    if HasParam('n') then downQuick := True;
    if HasParam('c') then cancelShutdown := True;
    if HasParam('p') then powerOff := True;
    if HasParam('l') then logoff := True;
    DoShutdown;
  end;
end.

Взято с

Для выполнения перезагрузки/выключения предназначены функции ExitWindows/ExitWindowsEx

ExitWindows:

Описание:
Function ExitWindows(Reserved: DWord; ReturnCode: Word): Bool;
Иницииpует стандаpтную пpоцедуpу завеpшения pаботы с Windows. Все пpикладные задачи должны подтвеpдить завеpшение pаботы Windows. Вызывает функцию 4CH пpеpывания 21H DOS.

Паpаметpы:
Reserved: Установлен в нуль.
ReturnCode: Значение, пеpедаваемое в DOS (в pегистpе AL).

Возвpащаемое значение:
Нуль, если одна или несколько задач отказываются завеpшить pаботу.

Примеры использования:
ExitWindows(EWX_LOGOFF,0); - завершение сеанса
ExitWindows(EWX_SHUTDOWN,0); - выключение компьютера
ExitWindows(EWX_REBOOT,0); - перезагрузка
Флаги EWX_FORCE, EWX_POWEROFF и EWX_FORCEIFHUNG могут комбинироваться к нужному действию.

ExitWindowsEx:
Функция ExitWindowsEx() представляет собой расширенный вариант ExitWindows().

Описание:
BOOL ExitWindowsEx( UINT uFlags, DWORD dwReserved, );
Функция ExitWindowsEx перезагружает(restart) или выключает систему (shutdown), а также может завершить сессию для текущего пользователя(log off).

Параметры:
uFlags -- флаг завершения работы, может принимать следущие значения:
EWX_LOGOFF завершает сессию текущего пользователя.
EWX_POWEROFF выключает питание компьютера(компьютер должен поддерживать данную функцию).
EWX_REBOOT перезагружает систему.
EWX_SHUTDOWN завершает работу комьпьютера до того места, где он может быть безопасно выключен: сброшенны все файловые буферы на диск, завершает работу всех процессов.
dwReserved --Зарезирвированно для последующих нужд, параметр игнорируется.

Возвращаемое значение:
Не ноль если всё прошло успешно

Пример использования:
ExitWindowsEx(EWX_SHUTDOWN,0);
Остальные примеры смотри в описании первой функции.

Вышеописанные примеры действительны только для w9x/Me.
Дело в том, что, чтобы выполнить функциию в NT ОС, нужно получить права на выполнение этой функции. Сделать это можно через AdjustTokenPriviligies.
С помощью нижеприведённой функции можно получить любую привелегию, в т.ч. и привеленгию SeShutdownPrivilege, которая нужна для разрешения функции ExitWindows(Ex)

Function SetPrivilege(aPrivilegeName: String; aEnabled: Boolean ): Boolean;
Var TPPrev,
      TP: TTokenPrivileges;
      Token: THandle;
      dwRetLen: DWord;
Begin
Result:=False;
OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, @Token );
TP.PrivilegeCount:=1;
IF LookupPrivilegeValue(nil,PChar(aPrivilegeName),TP.Privileges[0].LUID )) then
  Begin
   IF aEnabled then TP.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED
              else  TP.Privileges[0].Attributes:=0;
   dwRetLen:= 0;
   Result:=AdjustTokenPrivileges(Token,False,TP,SizeOf(TPPrev),TPPrev,dwRetLen);
  End;
CloseHandle(Token);
End;

Пример использования для среды NT:
SetPrivilege('SeShutdownPrivilege',True);
ExitWindowsEx(EWX_SHUTDOWN,0);

Автор:

Song

Взято из

Как выключить удалённый компьютер?

{-----------------------------------------------------------------------------
Unit Name:     formClient
Author:        Stewart Moss

Creation Date: 27 February, 2002 (16:30)
Documentation Date: 27 February, 2002 (16:30)

Version 1.0
-----------------------------------------------------------------------------

Description:

  This is to demonstrate shutting down a machine over the network.

  ** Tobias R. requests the article "How to send a shutdown command in a network?" **

  This is not really what you want. I think you are looking for some kind
  of IPC or RPC command. But this will work. Each machine needs to run
  a copy of this server.

  It uses the standard delphi ServerSocket found in the "ScktComp" unit.

  Create a form (name frmClient) with a TServerSocket on it (name ServerSocket)
  set the Port property of ServerSocket to 5555. Add a TMemo called Memo1.

  It listens on port 5555 using TCP/IP.

  It has a very simple protocol.
  Z = Show message with "Z"
  B = Beep
  S = Shutdown windows

  Run the program.. Then from the command prompt type in
  "telnet localhost 5555". Type in one of the three commands above
  (all in uppercase) and the server will respond.

Copyright 2002 by Stewart Moss. All rights reserved.
-----------------------------------------------------------------------------}

unit formClient;

interface

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

type
  TfrmClient = class(TForm)
    ServerSocket: TServerSocket;
    Memo1: TMemo;
    procedure ServerSocketClientRead(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmClient: TfrmClient;

implementation

{$R *.DFM}

procedure TfrmClient.ServerSocketClientRead(Sender: TObject;
  Socket: TCustomWinSocket);
var
  Incomming: string;
begin
  // read off the socket
  Incomming := Socket.ReceiveText;

  memo1.Lines.Add(incomming);

  if Incomming = 'S' then // Shutdown Protocol
    ExitWindowsEx(EWX_FORCE or EWX_SHUTDOWN, 0);

  if Incomming = 'B' then // Beep Protocol
    Beep;

  if Incomming = 'Z' then // Z protocol
    showmessage('Z');
end;

procedure TfrmClient.FormCreate(Sender: TObject);
begin
  ServerSocket.Active := true;
end;

procedure TfrmClient.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  ServerSocket.Active := false;
end;

end.

Взято с

Delphi Knowledge Base

Как выключить звук?

uses
  MMSystem;

function GetMasterMute(
  Mixer: hMixerObj;
  var Control: TMixerControl): MMResult;
  // Returns True on success
var
  Line: TMixerLine;
  Controls: TMixerLineControls;
begin
  ZeroMemory(@Line, SizeOf(Line));
  Line.cbStruct := SizeOf(Line);
  Line.dwComponentType := MIXERLINE_COMPONENTTYPE_DST_SPEAKERS;
  Result := mixerGetLineInfo(Mixer, @Line,
    MIXER_GETLINEINFOF_COMPONENTTYPE);
  if Result = MMSYSERR_NOERROR then
  begin
    ZeroMemory(@Controls, SizeOf(Controls));
    Controls.cbStruct := SizeOf(Controls);
    Controls.dwLineID := Line.dwLineID;
    Controls.cControls := 1;
    Controls.dwControlType := MIXERCONTROL_CONTROLTYPE_MUTE;
    Controls.cbmxctrl := SizeOf(Control);
    Controls.pamxctrl := @Control;
    Result := mixerGetLineControls(Mixer, @Controls,
      MIXER_GETLINECONTROLSF_ONEBYTYPE);
  end;
end;

procedure SetMasterMuteValue(
  Mixer: hMixerObj;
  Value: Boolean);
var
  MasterMute: TMixerControl;
  Details: TMixerControlDetails;
  BoolDetails: TMixerControlDetailsBoolean;
  Code: MMResult;
begin
  Code := GetMasterMute(0, MasterMute);
  if Code = MMSYSERR_NOERROR then
  begin
    with Details do
    begin
      cbStruct := SizeOf(Details);
      dwControlID := MasterMute.dwControlID;
      cChannels := 1;
      cMultipleItems := 0;
      cbDetails := SizeOf(BoolDetails);
      paDetails := @BoolDetails;
    end;
    LongBool(BoolDetails.fValue) := Value;
    Code := mixerSetControlDetails(0, @Details,
MIXER_SETCONTROLDETAILSF_VALUE);
  end;
  if Code <> MMSYSERR_NOERROR then
    raise Exception.CreateFmt('SetMasterMuteValue failure, '+
      'multimedia system error #%d', [Code]);
end;

// Example:

procedure TForm1.Button1Click(Sender: TObject);
begin
  SetMasterMuteValue(0, CheckBox1.Checked); // Mixer device #0 mute on/off
end;

Взято с сайта

Как выполнить create procedure/trigger при помощи TQuery?

Для этого у TQuery нужно установить property ParamCheck:=False. При этом текст запроса не будет проверяться на наличие параметров, которые предваряются двоеточием (:). Никаких других изменений не требуется.

Borland Interbase / Firebird FAQ
Borland Interbase / Firebird Q&A, версия 2.02 от 31 мая 1999
последняя редакция от 17 ноября 1999 года.
Часто задаваемые вопросы и ответы по Borland Interbase / Firebird
Материал подготовлен в Демо-центре клиент-серверных технологий. (Epsylon Technologies)
Материал не является официальной информацией компании Borland.
E-mail mailto:delphi@demo.ru
www: http://www.ibase.ru/
Телефоны: 953-13-34
источники: Borland International, Борланд АО, релиз Interbase 4.0, 4.1, 4.2, 5.0, 5.1, 5.5, 5.6, различные источники на WWW-серверах, текущая переписка, московский семинар по Delphi и конференции, листсервер ESUNIX1, листсервер mers.com.
Cоставитель: Дмитрий Кузьменко

Как выполнить Javascript функцию?

uses
  MSHTML_TLB, SHDocVw, ShellAPI;

// function to execute a script function

function ExecuteScript(doc: IHTMLDocument2; script: string; language: string): Boolean;
var
  win: IHTMLWindow2;
  Olelanguage: Olevariant;
begin
  if doc <> nil then
  begin
    try
      win := doc.parentWindow;
      if win <> nil then
      begin
        try
          Olelanguage := language;
          win.ExecScript(script, Olelanguage);
        finally
          win := nil;
        end;
      end;
    finally
      doc := nil;
    end;
  end;
end;

// 2 Examples how to login to gmx homepage

procedure FillInGMXForms(WB: ShDocVW_TLB.IWebbrowser2; IDoc1: IHTMLDocument2;
  Document: Variant; AKennung, APasswort: string);
const
  IEFields: array[1..4] of string = ('INPUT', 'text', 'INPUT', 'password');
var
  IEFieldsCounter: Integer;
  i: Integer;
  m: Integer;
  ovElements: OleVariant;
begin
  if Pos('GMX - Homepage', Document.Title) <> 0 then

    while WB.ReadyState <> READYSTATE_COMPLETE do
      Application.ProcessMessages;

  // count forms on document and iterate through its forms
  IEFieldsCounter := 0;
  for m := 0 to Document.forms.Length - 1 do
  begin
    ovElements := Document.forms.Item(m).elements;

    // iterate through elements
    for i := ovElements.Length - 1 downto 0 do
    begin
      try
        // if input fields found, try to fill them out
        if (ovElements.item(i).tagName = IEFields[1]) and
          (ovElements.item(i).type = IEFields[2]) then
        begin
          ovElements.item(i).Value := AKennung;
          Inc(IEFieldsCounter);
        end;

        if (ovElements.item(i).tagName = IEFields[3]) and
          (ovElements.item(i).type = IEFields[4]) then
        begin
          ovElements.item(i).Value := APasswort;
          Inc(IEFieldsCounter);
        end;
      except
        // failed...
      end;
    end; { for i...}
  end;  { for m }
  // if the fields are filled in, submit.
  if IEFieldsCounter = 3 then ExecuteScript(iDoc1, 'document.login.submit()',
      'JavaScript');
end;

function LoginGMX_IE(AKennung, APasswort: string): Boolean;
var
  ShellWindow: IShellWindows;
  WB: ShDocVW_TLB.IWebbrowser2;
  spDisp: IDispatch;
  IDoc1: IHTMLDocument2;
  Document: Variant;
  k: Integer;
begin
  ShellWindow := CoShellWindows.Create;
  // get the running instance of Internet Explorer
  for k := 0 to ShellWindow.Count do
  begin
    spDisp := ShellWindow.Item(k);
    if spDisp = nil then Continue;
    // QueryInterface determines if an interface can be used with an object
    spDisp.QueryInterface(iWebBrowser2, WB);
    if WB <> nil then
    begin
      WB.Document.QueryInterface(IHTMLDocument2, iDoc1);
      if iDoc1 <> nil then
      begin
        WB := ShellWindow.Item(k) as ShDocVW_TLB.IWebbrowser2;
        Document := WB.Document;
        // if GMX page...
        FillInGMXForms(WB, IDoc1, Document, AKennung, APasswort);
      end;  { idoc <> nil }
    end; { wb <> nil }
  end;  { for k }
end;

// Example 1: Navigate to the gmx homepage in the IE browser an login
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShellExecute(Handle,
    'open',
    'http://www.gmx.ch',
    nil,
    nil,
    SW_SHOW);
  Sleep(2000);
  LoginGMX_IE('user@gmx.net', 'pswd');
end;

// Example 2: navigate to the gmx homepage in the Webbrowser an login
procedure TForm1.Button2Click(Sender: TObject);
var
  IDoc1: IHTMLDocument2;
  Web: ShDocVW_TLB.IWebBrowser2;
begin
  Webbrowser1.Navigate('http://www.gmx.ch');
  while Webbrowser1.ReadyState <> READYSTATE_COMPLETE do
    Application.ProcessMessages;
  Webbrowser1.Document.QueryInterface(IHTMLDocument2, iDoc1);
  Web := WebBrowser1.ControlInterface;
  FillInGMXForms(Web, iDoc1, Webbrowser1.Document, 'user@gmx.net', 'pswd');
end;
Взято с сайта

Как выполнить какой-то процесс тогда, когда пользователь не работает с моим приложением?

Создайте процедуру, которая будет вызываться при событии Application.OnIdle.

Обьявим процедуру:
{Private declarations}

procedure IdleEventHandler(Sender: TObject; var Done: Boolean);

В разделе implementation опишем поцедуру:

procedure TForm1.IdleEventHandler(Sender: TObject; var Done: Boolean);
begin
{Do a small bit of work here}
Done := false;
end;

В методе Form'ы OnCreate - укажем что наша процедура вызывается на событии
Application.OnIdle.

Application.OnIdle := IdleEventHandler;
Событие OnIdle возникает один раз - когда приложение переходит в режим "безделья" (idle). Если в обработчике переменной Done присвоить False событие будет вызываться вновь и вновь, до тех пор пока приложение "бездельничает" и переменной Done не присвоенно значение True.

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

{... }
type
  PYourMethod = ^TYourMethod;
  TYourMethod = procedure(S: string) of Object;

procedure TMainForm.Button1Click(Sender: TObject);
begin
  ExecMethodByName('SomeMethod');
end;

procedure TMainForm.ExecMethodByName(AName: string);
var
  PAddr: PYourMethod;
  M: TMethod;
begin
  PAddr := MethodAddress(AName);
  if PAddr <> nil then
  begin
    M.Code := PAddr;
    M.Data := Self;
    TYourMethod(M)('hello');
  end;
end;

procedure TMainForm.SomeMethod(S: string);
begin
  ShowMessage(S);
end;

Tip by Sasan Adami

Взято из

Как выровнять иконки на рабочем столе к левому краю?

Для начала необходимо получить дескриптор рабочего стола, который представляет из себя обычный ListView.
Пример:

function GetDesktopListViewHandle: THandle;
var
S: String;
begin
Result := FindWindow('ProgMan', nil);
Result := GetWindow(Result, GW_CHILD);
Result := GetWindow(Result, GW_CHILD);
SetLength(S, 40);
GetClassName(Result, PChar(S), 39);
if PChar(S) <> 'SysListView32' then Result := 0;
end;

Как только дескриптор рабочего стола получен, можно с ним работать при помощи обычных API функций (через юнит CommCtrl). См. сообщения LVM_xxxx в хелпе по Win32.

Следующая строчка кода выравнивает иконки на рабочем столе к левому краю:

SendMessage(GetDesktopListViewHandle,LVM_ALIGN,LVA_ALIGNLEFT,0);

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

Как вывести цветной текст в TStatusBar?

Статусбар, это стандартный элемент управления Windows и как все отображает шрифт, заданный в параметре clBtnText, который устанавливается через Панель управления. Поумолчанию этот цвет чёрный, но он может менятся в зависимоти пользовательской темы. StatusBar и связанные с ним панели имеют возможность самостоятельной перерисовки (owner-draw), позволяющей рисовать текст различными цветами. Для этого необходимо в TStatusBar.Panels установить свойство Style в OwnerDraw.

procedure TForm1.StatusBar1DrawPanel(StatusBar: TStatusBar;
  Panel: TStatusPanel; const Rect: TRect);
begin
  if Panel = StatusBar.Panels[0] then begin
    StatusBar.Canvas.Font.Color := clRed;
    StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 0')
  end else begin
    StatusBar.Canvas.Font.Color := clGreen;
    StatusBar.Canvas.TextOut(Rect.Left, Rect.Top, 'Panel - 1');
  end;
end;

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

Как вывести данные в Excel?

Можно выводить данные последовательно в каждую ячейку, но это очинь сильно замедляет работу. Лучше сформировать вариантный массив, и выполнить присвоение области (Range) этого массива.
var
    ExcelApp, Workbook, Range, Cell1, Cell2, ArrayData  : Variant;
    TemplateFile : String;
    BeginCol, BeginRow, i, j : integer;
    RowCount, ColCount : integer;
begin
  // Координаты левого верхнего угла области, в которую будем выводить данные
  BeginCol := 1;
  BeginRow := 5;

  // Размеры выводимого массива данных
  RowCount := 100;
  ColCount := 50;

  // Создание Excel
  ExcelApp := CreateOleObject('Excel.Application');

  // Отключаем реакцию Excel на события, чтобы ускорить вывод информации
  ExcelApp.Application.EnableEvents := false;

  //  Создаем Книгу (Workbook)
  //  Если заполняем шаблон, то Workbook := ExcelApp.WorkBooks.Add('C:\MyTemplate.xls');
  Workbook := ExcelApp.WorkBooks.Add;

  // Создаем Вариантный Массив, который заполним выходными данными
  ArrayData := VarArrayCreate([1, RowCount, 1, ColCount], varVariant);

  // Заполняем массив
  for I := 1 to RowCount do
    for J := 1 to ColCount do
      ArrayData[I, J] := J * 10 + I;

  // Левая верхняя ячейка области, в которую будем выводить данные
  Cell1 := WorkBook.WorkSheets[1].Cells[BeginRow, BeginCol];
  // Правая нижняя ячейка области, в которую будем выводить данные
  Cell2 := WorkBook.WorkSheets[1].Cells[BeginRow  + RowCount - 1, BeginCol +
ColCount - 1];

  // Область, в которую будем выводить данные
  Range := WorkBook.WorkSheets[1].Range[Cell1, Cell2];

  // А вот и сам вывод данных
  // Намного быстрее поячеечного присвоения
  Range.Value := ArrayData;

  // Делаем Excel видимым
  ExcelApp.Visible := true;

Автор Кулюкин Олег
Взято с сайта

Как вывести главное окно справочной системы?

В 16-битных версиях справочной системы необходимо было вызывать начальное (главное) окно помощи с параметром HELP_CONTENTS в комманде HelpCommand. В 32-битном варианте это осуществляется следующим образом:

Application.HelpCommand(HELP_FINDER, 0);

Примечание : Для того, чтобы показывались "книжки" (или главные темы) - необходимо создать .CNT-файл.

Как вывести окно свойств компьютеpа?

ShellExecute(Application.Handle, 'open', 'sysdm.cpl', nil, nil,sw_ShowNormal);

Взято с сайта

Как вывести результат работы консоли в Memo?

Код взят из

procedure Dos2Win(CmdLine:String; OutMemo:TMemo);
const BUFSIZE = 2000;
var SecAttr    : TSecurityAttributes;
    hReadPipe,
    hWritePipe : THandle;
    StartupInfo: TStartUpInfo;
    ProcessInfo: TProcessInformation;
    Buffer     : Pchar;
    WaitReason,
    BytesRead  : DWord;
begin

with SecAttr do
begin
   nlength              := SizeOf(TSecurityAttributes);
   binherithandle       := true;
   lpsecuritydescriptor := nil;
end;
// Creazione della pipe
if Createpipe (hReadPipe, hWritePipe, @SecAttr, 0) then
begin
   Buffer  := AllocMem(BUFSIZE + 1);    // Allochiamo un buffer di dimensioni BUFSIZE+1
   FillChar(StartupInfo, Sizeof(StartupInfo), #0);
   StartupInfo.cb          := SizeOf(StartupInfo);
   StartupInfo.hStdOutput  := hWritePipe;
   StartupInfo.hStdInput   := hReadPipe;
   StartupInfo.dwFlags     := STARTF_USESTDHANDLES +
                              STARTF_USESHOWWINDOW;
   StartupInfo.wShowWindow := SW_HIDE;

   if CreateProcess(nil,
      PChar(CmdLine),
      @SecAttr,
      @SecAttr,
      true,
      NORMAL_PRIORITY_CLASS,
      nil,
      nil,
      StartupInfo,
      ProcessInfo) then
     begin
       // Attendiamo la fine dell'esecuzione del processo
       repeat
         WaitReason := WaitForSingleObject( ProcessInfo.hProcess,100);
         Application.ProcessMessages;
       until (WaitReason <> WAIT_TIMEOUT);
       // Leggiamo la pipe
       Repeat
         BytesRead := 0;
         // Leggiamo "BUFSIZE" bytes dalla pipe
         ReadFile(hReadPipe, Buffer[0], BUFSIZE, BytesRead, nil);
         // Convertiamo in una stringa "\0 terminated"
         Buffer[BytesRead]:= #0;
         // Convertiamo i caratteri da DOS ad ANSI
         OemToAnsi(Buffer,Buffer);
         // Scriviamo nell' "OutMemo" l'output ricevuto tramite pipe
         OutMemo.Text := OutMemo.text + String(Buffer);
       until (BytesRead < BUFSIZE);
     end;
   FreeMem(Buffer);
   CloseHandle(ProcessInfo.hProcess);
   CloseHandle(ProcessInfo.hThread);
   CloseHandle(hReadPipe);
   CloseHandle(hWritePipe);
end;
end;
Взято с Vingrad.ru

А это исправленный Song'ом вариант для обеспечения вывода текста в real-time:

procedure RunDosInMemo(CmdLine:String;AMemo:TMemo);
const
   ReadBuffer = 2400;
var
  Security       : TSecurityAttributes;
  ReadPipe,WritePipe  : THandle;
  start        : TStartUpInfo;
  ProcessInfo     : TProcessInformation;
  Buffer        : Pchar;
  BytesRead      : DWord;
  Apprunning      : DWord;
begin
  Screen.Cursor:=CrHourGlass;
  Form1.Button1.Enabled:=False;
  With Security do begin
  nlength        := SizeOf(TSecurityAttributes);
  binherithandle    := true;
  lpsecuritydescriptor := nil;
  end;
  if Createpipe (ReadPipe, WritePipe,
         @Security, 0) then begin
  Buffer  := AllocMem(ReadBuffer + 1);
  FillChar(Start,Sizeof(Start),#0);
  start.cb      := SizeOf(start);
  start.hStdOutput  := WritePipe;
  start.hStdInput  := ReadPipe;
  start.dwFlags   := STARTF_USESTDHANDLES +
             STARTF_USESHOWWINDOW;
  start.wShowWindow := SW_HIDE;

  if CreateProcess(nil,
      PChar(CmdLine),
      @Security,
      @Security,
      true,
      NORMAL_PRIORITY_CLASS,
      nil,
      nil,
      start,
      ProcessInfo)
  then
  begin
   repeat
   Apprunning := WaitForSingleObject
          (ProcessInfo.hProcess,100);
    ReadFile(ReadPipe,Buffer[0],
       ReadBuffer,BytesRead,nil);
    Buffer[BytesRead]:= #0;
    OemToAnsi(Buffer,Buffer);
    AMemo.Text := AMemo.text + String(Buffer);

   Application.ProcessMessages;
   until (Apprunning <> WAIT_TIMEOUT);
  end;
  FreeMem(Buffer);
  CloseHandle(ProcessInfo.hProcess);
  CloseHandle(ProcessInfo.hThread);
  CloseHandle(ReadPipe);
  CloseHandle(WritePipe);
  end;
  Screen.Cursor:=CrDefault;
  Form1.Button1.Enabled:=True;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Memo1.Clear;
RunDosInMemo('ping -t 192.168.28.200',Memo1);
end;

Взято с Vingrad.ru

Автор: Алексей Бойко

Это пример запуска консольных программ с передачей ей консольного ввода (как если бы он был введен с клавиатуры после запуска программы) и чтением консольного вывода. Таким способом можно запускать например стандартный виндовый ftp.exe (в невидимом окне) и тем самым отказаться от использования специализированных, зачастую глючных компонент.

function ExecuteFile(FileName,StdInput: string;
                     TimeOut: integer;
                     var StdOutput:string) : boolean;

label Error;

type
  TPipeHandles = (IN_WRITE,  IN_READ,
                  OUT_WRITE, OUT_READ,
                  ERR_WRITE, ERR_READ);

type
  TPipeArray = array [TPipeHandles] of THandle;

var
  i         : integer;
  ph        : TPipeHandles;
  sa        : TSecurityAttributes;
  Pipes     : TPipeArray;
  StartInf  : TStartupInfo;
  ProcInf   : TProcessInformation;
  Buf       : array[0..1024] of byte;
  TimeStart : TDateTime;

function ReadOutput : string;
var
  i : integer;
  s : string;
  BytesRead : longint;

begin
  Result := '';
  repeat

    Buf[0]:=26;
    WriteFile(Pipes[OUT_WRITE],Buf,1,BytesRead,nil);
    if ReadFile(Pipes[OUT_READ],Buf,1024,BytesRead,nil) then
    begin
      if BytesRead>0 then
      begin
        buf[BytesRead]:=0;
        s := StrPas(@Buf[0]);
        i := Pos(#26,s);
        if i>0 then s := copy(s,1,i-1);
        Result := Result + s;
      end;
    end;

    if BytesRead1024 then break;
  until false;
end;

begin
  Result := false;
  for ph := Low(TPipeHandles) to High(TPipeHandles) do
    Pipes[ph] := INVALID_HANDLE_VALUE;

  // Создаем пайпы
  sa.nLength := sizeof(sa);
  sa.bInheritHandle := TRUE;
  sa.lpSecurityDescriptor := nil;

  if not CreatePipe(Pipes[IN_READ],Pipes[IN_WRITE], @sa, 0 ) then
    goto Error;
  if not CreatePipe(Pipes[OUT_READ],Pipes[OUT_WRITE], @sa, 0 ) then
    goto Error;
  if not CreatePipe(Pipes[ERR_READ],Pipes[ERR_WRITE], @sa, 0 ) then
    goto Error;

  // Пишем StdIn
  StrPCopy(@Buf[0],stdInput+^Z);
  WriteFile(Pipes[IN_WRITE],Buf,Length(stdInput),i,nil);

  // Хендл записи в StdIn надо закрыть - иначе выполняемая программа
  // может не прочитать или прочитать не весь StdIn.

  CloseHandle(Pipes[IN_WRITE]);

  Pipes[IN_WRITE] := INVALID_HANDLE_VALUE;

  FillChar(StartInf,sizeof(TStartupInfo),0);
  StartInf.cb := sizeof(TStartupInfo);
  StartInf.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;

  StartInf.wShowWindow := SW_SHOW; // SW_HIDE если надо запустить невидимо

  StartInf.hStdInput := Pipes[IN_READ];
  StartInf.hStdOutput := Pipes[OUT_WRITE];
  StartInf.hStdError := Pipes[ERR_WRITE];

  if not CreateProcess(nil, PChar(FileName), nil,
                       nil, True, NORMAL_PRIORITY_CLASS,
                       nil, nil, StartInf, ProcInf) then goto Error;

  TimeStart := Now;

  repeat
    Application.ProcessMessages;
    i := WaitForSingleObject(ProcInf.hProcess,100);
    if i = WAIT_OBJECT_0 then break;
    if (Now-TimeStart)*SecsPerDay>TimeOut then break;
  until false;

  if iWAIT_OBJECT_0 then goto Error;
  StdOutput := ReadOutput;

  for ph := Low(TPipeHandles) to High(TPipeHandles) do
    if Pipes[ph]INVALID_HANDLE_VALUE then
      CloseHandle(Pipes[ph]);

  CloseHandle(ProcInf.hProcess);
  CloseHandle(ProcInf.hThread);
  Result := true;
  Exit;

Error:

  if ProcInf.hProcessINVALID_HANDLE_VALUE then

  begin
    CloseHandle(ProcInf.hThread);
    i := WaitForSingleObject(ProcInf.hProcess, 1000);
    CloseHandle(ProcInf.hProcess);
    if iWAIT_OBJECT_0 then

    begin
      ProcInf.hProcess := OpenProcess(PROCESS_TERMINATE,
                                      FALSE,
                                      ProcInf.dwProcessId);

      if ProcInf.hProcess  0 then
      begin
        TerminateProcess(ProcInf.hProcess, 0);
        CloseHandle(ProcInf.hProcess);
      end;
    end;
  end;

  for ph := Low(TPipeHandles) to High(TPipeHandles) do
    if Pipes[ph]INVALID_HANDLE_VALUE then
      CloseHandle(Pipes[ph]);

end;

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

Как вывести текст, написанный под углом?

Для того чтобы вывести текст под углом, вытянуть или сжать его нужно воспользоваться структурой LOGFONT. Здесь показаны не все ее возможности, но, на мой взгляд, самые интересные.

procedure TForm1.FormPaint(Sender: TObject);
var
  lf: TLogFont;
begin
  FillChar(lf, SizeOf(lf), 0);
  with lf do begin
    // Высота буквы
    lfHeight := 15;

    // Ширина буквы
    lfWidth := 20;

    // Угол наклона в десятых градуса
    lfEscapement := 100;

     // Жирность 0..1000, 0 - по умолчанию
    lfWeight := 1000;

    // Курсив
    lfItalic := 0;

    // Подчеркнут
    lfUnderline := 1;

    // Зачеркнут
    lfStrikeOut := 1;

    // CharSet
    lfCharSet := RUSSIAN_CharSet;

    // Название шрифта
    StrCopy(lfFaceName, 'Arial');
  end;
  with Form1.Canvas do begin
    FillRect(ClipRect);
    Font.Handle := CreateFontIndirect(lf);
    TextOut(0, 100, 'It is a text string');
  end;
end;

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

{ Эта процедура устанавливает угол вывода текста для указанного Canvas, угол в градусах }
{ Шрифт должен быть TrueType ! }
procedure CanvasSetTextAngle(c: TCanvas; d: single);
var   LogRec: TLOGFONT;     { Информация о шрифте }
begin
{Читаем текущюю инф. о шрифте }
GetObject(c.Font.Handle,SizeOf(LogRec) ,Addr(LogRec) );
{ Изменяем угол }
LogRec.lfEscapement := round(d*10);
{ Устанавливаем новые параметры }
c.Font.Handle := CreateFontIndirect(LogRec);
end;

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

Как вывести текст с красивым обрезанием если не помещается?

Используй вызов DrawTextEx, установив в параметре dwDTFormat значение DT_PATH_ELLIPSIS.

procedureTForm1.FormPaint(Sender: TObject);
var
  r: TRect;
begin
  r := Rect(20, 20, 110, 70);
  // DT_PATH_ELLIPSIS or DT_WORD_ELLIPSIS or DT_END_ELLIPSIS
  DrawTextEx(Form1.Canvas.Handle, 'Delphi World - это круто!!!',
   25, r, DT_WORD_ELLIPSIS, nil);
end;

Взято из

Как вывести звук через звуковую карту?

uses
  MMSystem;

type
  TVolumeLevel = 0..127;

procedure MakeSound(Frequency{Hz}, Duration{mSec}: Integer; Volume: TVolumeLevel);
  {writes tone to memory and plays it}
var
  WaveFormatEx: TWaveFormatEx;
  MS: TMemoryStream;
  i, TempInt, DataCount, RiffCount: integer;
  SoundValue: byte;
  w: double; // omega ( 2 * pi * frequency)
const
  Mono: Word = $0001;
  SampleRate: Integer = 11025; // 8000, 11025, 22050, or 44100
  RiffId: string = 'RIFF';
  WaveId: string = 'WAVE';
  FmtId: string = 'fmt ';
  DataId: string = 'data';
begin
  if Frequency > (0.6 * SampleRate) then
  begin
    ShowMessage(Format('Sample rate of %d is too Low to play a tone of %dHz',
      [SampleRate, Frequency]));
    Exit;
  end;
  with WaveFormatEx do
  begin
    wFormatTag := WAVE_FORMAT_PCM;
    nChannels := Mono;
    nSamplesPerSec := SampleRate;
    wBitsPerSample := $0008;
    nBlockAlign := (nChannels * wBitsPerSample) div 8;
    nAvgBytesPerSec := nSamplesPerSec * nBlockAlign;
    cbSize := 0;
  end;
  MS := TMemoryStream.Create;
  with MS do
  begin
    {Calculate length of sound data and of file data}
    DataCount := (Duration * SampleRate) div 1000; // sound data
    RiffCount := Length(WaveId) + Length(FmtId) + SizeOf(DWORD) +
      SizeOf(TWaveFormatEx) + Length(DataId) + SizeOf(DWORD) + DataCount; // file data
    {write out the wave header}
    Write(RiffId[1], 4); // 'RIFF'
    Write(RiffCount, SizeOf(DWORD)); // file data size
    Write(WaveId[1], Length(WaveId)); // 'WAVE'
    Write(FmtId[1], Length(FmtId)); // 'fmt '
    TempInt := SizeOf(TWaveFormatEx);
    Write(TempInt, SizeOf(DWORD)); // TWaveFormat data size
    Write(WaveFormatEx, SizeOf(TWaveFormatEx)); // WaveFormatEx record
    Write(DataId[1], Length(DataId)); // 'data'
    Write(DataCount, SizeOf(DWORD)); // sound data size
    {calculate and write out the tone signal} // now the data values
    w := 2 * Pi * Frequency; // omega
    for i := 0 to DataCount - 1 do
    begin
      SoundValue := 127 + trunc(Volume * sin(i * w / SampleRate)); // wt = w * i / SampleRate
      Write(SoundValue, SizeOf(Byte));
    end;
    {now play the sound}
    sndPlaySound(MS.Memory, SND_MEMORY or SND_SYNC);
    MS.Free;
  end;
end;

// How to call the function:

procedure TForm1.Button1Click(Sender: TObject);
begin
  MakeSound(1200, 1000, 60);
end;

Взято с сайта

Как вызвать команды Find, Option или View Source?

Взято из FAQ:
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Вот пример вызова диалога

const
HTMLID_FIND = 1;
HTMLID_VIEWSOURCE = 2;
HTMLID_OPTIONS = 3; ...

procedure TForm1.FindIE;
const
CGID_WebBrowser: TGUID = '{ED016940-BD5B-11cf-BA4E-00C04FD70816}';
var
CmdTarget : IOleCommandTarget;
vaIn, vaOut: OleVariant;
PtrGUID: PGUID;
begin
New(PtrGUID);
PtrGUID^ := CGID_WebBrowser;
if WebBrowser1.Document < > nil then
try
WebBrowser1.Document.QueryInterface(IOleCommandTarget, CmdTarget);
if CmdTarget < > nil then
try
  CmdTarget.Exec( PtrGUID, HTMLID_FIND, 0, vaIn, vaOut);
finally
  CmdTarget._Release;
end;
except
  // Ни?его
end;
Dispose(PtrGUID);
end;

Как вызвать метод предка?

1) Есть Class1, с методом Mtd.
2) Есть Class2 унаследованный от Class1, метод Mtd перезаписан
3) В программе используется переменная типа Class2
Можно ли из программы вызвать Mtd от Class1, Другими словами, можно ли вызвать перезаписанный метод класса-предка?

Способ 1(только для не виртуальных методов)

var
a:class2;
begin
a:=class2.Create;
class1(a).mtd;
....
end;

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

Способ со статическим приведением годится только для
не виртуальных методов, имеющих одно имя.
Вызов же виртуальных методов от статического типа не зависит.
В твоём простейшем случае достаточно написать inherited Mtd;
(ты его можешь вызвать из любого метода TClass2, не только из Mtd).
Трудности возникнут, когда нужно вызвать метод "дедушки" или "прадедушки" и т.д.
Один из способов, описанных в литературе, - временная замена
VMT объекта на "дедушку" и обратно. Но если у дедушки такого метода не было - будет облом.
Я предпочитаю такой способ:

type
TProc = procedure of object;
procedure TClassN.SomeMethod;
var
Proc: TProc;
begin
TMethod(Proc).Code := @TClass1.Mtd; // Статический адрес
TMethod(Proc).Data := Self;
Proc();
end;

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

Как вызвать подсказку к подсказке?

В Delphi-приложении можно вызвать помощь в пользовании системой помощи следующим образом:

Application.HelpCommand(Help_HelpOnHelp, 0);

Как вызывать функцию 16-битной DLL из 32-битного приложения?

Надо использовать Thunks.

Кусок работающего только под Windows 95 кода -

const
Gfsr_SystemResources = 0;
   Gfsr_GdiResources = 1;
   Gfsr_UserResources = 2;
var
   hInst16: THandle;
   GFSR: Pointer;
{ Undocumented Kernel32 calls. }
function LoadLibrary16(LibraryName: PChar): THandle; stdcall; external kernel32 index 35;
procedure FreeLibrary16(HInstance: THandle); stdcall; external kernel32 index 36;
function GetProcAddress16(Hinstance: THandle; ProcName: PChar): Pointer; stdcall; external kernel32 index 37;
procedure QT_Thunk; cdecl; external kernel32 name 'QT_Thunk';
{ QT_Thunk needs a stack frame. }
{$StackFrames On}
{ Thunking call to 16-bit USER.EXE. The ThunkTrash argument
allocates space on the stack for QT_Thunk. }
function NewGetFreeSystemResources(SysResource: Word): Word;
var
   ThunkTrash: array[0..$20] of Word;
begin
   { Prevent the optimizer from getting rid of ThunkTrash. }
   ThunkTrash[0] := hInst16;
   hInst16 := LoadLibrary16('user.exe');
   if hInst16 < 32 then
     raise Exception.Create('Cannot load USER.EXE!');
   { Decrement the usage count. This doesn't really free the
     library, since USER.EXE is always loaded. }
   FreeLibrary16(hInst16);
   { Get the function pointer for the 16-bit function in USER.EXE. }
   GFSR := GetProcAddress16(hInst16, 'GetFreeSystemResources');
   if GFSR = nil then
     raise Exception.Create('Cannot get address of GetFreeSystemResources!');
   { Thunk down to USER.EXE. }
   asm
     push SysResource { push arguments }
     mov edx, GFSR { load 16-bit procedure pointer }
     call QT_Thunk { call thunk }
     mov Result, ax { save the result }
   end;
end;
Автор - Quality freeware from Sight&Sound, Slovenia : http://www.sight-sound.si

Андрей Гусев (Andrey Gusev)

Взято из Akzhan's Delphi-related VCL&WinAPI Tips'n'Tricks

Посылаю код для определения системных ресурсов (как в "Индикаторе ресурсов"). Использовалась статья "Calling 16-bit code from 32-bit in Windows 95".

{ GetFeeSystemResources routine for 32-bit Delphi.

Works only under Windows 9x }

unit SysRes32;

interface

const
//Constants whitch specifies the type of resource to be checked

GFSR_SYSTEMRESOURCES = $0000;
GFSR_GDIRESOURCES    = $0001;
GFSR_USERRESOURCES   = $0002;

// 32-bit function exported from this unit

function GetFeeSystemResources(SysResource: Word):Word;

implementation

uses

SysUtils, Windows;

type

//Procedural variable for testing for a nil

TGetFSR = function(ResType: Word): Word; stdcall;

//Declare our class exeptions

EThunkError = class(Exception);
EFOpenError = class(Exception);

var

User16Handle : THandle = 0;
GetFSR       : TGetFSR = nil;

//Prototypes for some undocumented API

function LoadLibrary16(LibFileName: PAnsiChar): THandle; stdcall;
external kernel32 index 35;

function FreeLibrary16(LibModule: THandle): THandle; stdcall;
external kernel32 index 36;

function GetProcAddress16(Module: THandle; ProcName: LPCSTR): TFarProc;stdcall;
external kernel32 index 37;

procedure QT_Thunk; cdecl;
external 'kernel32.dll' name 'QT_Thunk';

{$StackFrames On}

function GetFeeSystemResources(SysResource: Word):Word;
var

EatStackSpace: String[$3C];
begin
// Ensure buffer isn't optimised away

EatStackSpace := '';
@GetFSR:=GetProcAddress16(User16Handle,'GETFREESYSTEMRESOURCES');
if  Assigned(GetFSR) then  //Test result for nil
asm
//Manually push onto the stack type of resource to be checked first

push  SysResource
//Load routine address into EDX

mov   edx, [GetFSR]
//Call routine

call  QT_Thunk
//Assign result to the function

mov   @Result, ax
end
else raise EFOpenError.Create('GetProcAddress16 failed!');
end;

initialization

//Check Platform for Windows 9x
if Win32Platform <> VER_PLATFORM_WIN32_WINDOWS then

raise EThunkError.Create('Flat thunks only supported under Windows 9x');

//Load 16-bit DLL (USER.EXE)
User16Handle:= LoadLibrary16(PChar('User.exe'));

if User16Handle < 32 then
raise EFOpenError.Create('LoadLibrary16 failed!');

finalization

//Release 16-bit DLL when done
if User16Handle <> 0 then

FreeLibrary16(User16Handle);

end.

Взято с

Как взять URL из окна IE?

uses windows, ddeman, ......

function Get_URL(Servicio: string): String;
uses windows, ddeman, ......

function Get_URL(Servicio: string): String;
var
  Cliente_DDE: TDDEClientConv;
  temp:PChar;
begin
   Result := '';
   Cliente_DDE:= TDDEClientConv.Create( nil );
    with Cliente_DDE do
       begin
          SetLink( Servicio,'WWW_GetWindowInfo');
          temp := RequestData('0xFFFFFFFF');
          Result := StrPas(temp);
          StrDispose(temp);  //<<-Предотвращаем утечку памяти
          CloseLink;
       end;
     Cliente_DDE.Free;
end;

procedure TForm1.Button1Click(Sender);
begin
  showmessage(Get_URL('Netscape'));
     или
  showmessage(Get_URL('IExplore'));
end;

Автор ответа: Song

Взято с Vingrad.ru

Пример показывает, как найти окно Internet Explorer, и захватить из него текущий URL, находящийся в поле адреса IE. В Исходнике используются простые функции win32 api на delphi.

function GetText(WindowHandle: hwnd): string;
var
  txtLength: integer;
  buffer: string;
begin
  TxtLength := SendMessage(WindowHandle, WM_GETTEXTLENGTH, 0, 0);
  txtlength := txtlength + 1;
  setlength(buffer, txtlength);
  sendmessage(WindowHandle, wm_gettext, txtlength, longint(@buffer[1]));
  result := buffer;
end;

function GetURL: string;
var
  ie, toolbar, combo,
    comboboxex, edit,
    worker, toolbarwindow: hwnd;
begin
  ie := FindWindow(pchar('IEFrame'), nil);
  worker := FindWindowEx(ie, 0, 'WorkerA', nil);
  toolbar := FindWindowEx(worker, 0, 'rebarwindow32', nil);
  comboboxex := FindWindowEx(toolbar, 0, 'comboboxex32', nil);
  combo := FindWindowEx(comboboxex, 0, 'ComboBox', nil);
  edit := FindWindowEx(combo, 0, 'Edit', nil);
  toolbarwindow := FindWindowEx(comboboxex, 0, 'toolbarwindow32', nil);

  result := GetText(edit);
{-------------------------------------------------------}

procedure TForm1.Button1Click(Sender: TObject);
begin
  showmessage(GetURL);
end;

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

Как заблокировать функцию вставки записи в компоненте TDBGrid?

Не могли бы вы подсказать, как заблокировать функцию вставки записи непосредственно в компоненте TDBGrid с сохранением всех остальных возможностей редактирования таблицы.

Наиболее разумным представляется создать обработчик события OnBeforeInsert компонента TTable, TQuery или TClientDataSet, данные из которых отображаются в TDBGrid. Сам компонент TDBGrid не имеет подходящего события для обработки, так как это компонент, предназначенный только для создания пользовательского интерфейса, а в данном случае следует, по существу, запретить добавление записей в таблицу.

Наталия Елманова
Взято с Исходников.ru

Как заблокировать компьютер?

procedure LockPC;
var OldValue: LongBool;
begin
SystemParametersInfo(97, Word(Bool), @OldValue, 0);
WinExec(PChar('rundll32 mouse,disable'), SW_SHOW);
WinExec(PChar('rundll32 keyboard,disable'), SW_SHOW);
end;

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

Как заблокировать реакцию на клавиатуру компонента?

В обработчике события onKeyDown попробуй поставить:

Key:=0;

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

Как задать выражение по умолчанию для объекта TField

Это будет работать, если вы уже установили атрибуты поля и ассоциировали его с полем вашей таблицы. Если вы установили значение в Инспекторе Объектов, т.е. задали строку, не думайте, что это сработает во время выполнения приложения. Если вы попытаетесь во время прогона установить свойство TField.DefaultExpression примерно так:

MyField.DefaultExpression:= 'MyValue';

то это скомпилируется, но при создании в таблице новой записи, скажем, при щелчке на кнопке + в DBNavigator, значения по умолчанию вы не получите. Чтобы во время работы приложения все работало, код должен быть таким:

MyField.DefaultExpression := '''MyValue''';

В Инспекторе Объектов вам нужно просто поместить значение 'MyValue' (используя одинарные кавычки).

Взято из

Как зафиксировать один или несколько столбцов в TDBGrid с возможностью навигации по этим столбцам?

procedureTDbGridEx.ColEnter;

procedure ProcessColEnter;
begin
// -----------------------------------------------------------
if (SelectedIndex  _Mark) then
   begin
     ColumnMoved(Columns.Count, StaticCol + 1);
     SelectedField := Fields[StaticCol];
   end;
   Exit;
end;

// -----------------------------------------------------------
if (SelectedIndex > StaticCol) then
begin

   if _LastSelectedIndex = StaticCol then
   begin
     if _Mark = Columns[SelectedIndex].Title.Caption then

     begin
       ColumnMoved(StaticCol + 1, Columns.Count);
       SelectedField := Fields[Columns.Count - 1];
     end
       else
     begin
       ColumnMoved(StaticCol + 1, Columns.Count);
       SelectedField := Fields[StaticCol];
     end;
   end;

end;
end;

begin
if (_EntryCol > 0) or _MouseDown or (StaticCol = 0) then
begin
   _MouseDown := FALSE;
end else
begin
   inc(_EntryCol);
   ProcessColEnter;
   dec(_EntryCol);
end;

if Assigned(OnColEnter) then OnColEnter(Self);

_LastSelectedIndex := SelectedIndex;
end;
Автор: Ramil Galiev
(2:5085/33.11)

Автор:

StayAtHome

Взято из

Как загрузить BMP файл из DLL?

procedure TForm1.Button1Click(Sender: TObject);
var
  AModule: THandle;
begin
  AModule := LoadLibrary('Images.dll');
  image1.Picture.BitMap.LoadFromResourceName(AModule, 'StartMine');
  FreeLibrary(AModule);
end;

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

Как загрузить файл?

{
  The following function shows how to connect to a ftp server
  and download a file.
  It uses the functions from wininet.dll.

  You need a ProgressBar to show the progress and a Label to show progress informations.
}

uses
  WinInet, ComCtrls;

function FtpDownloadFile(strHost, strUser, strPwd: string;
  Port: Integer; ftpDir, ftpFile, TargetFile: string; ProgressBar: TProgressBar): Boolean;

  function FmtFileSize(Size: Integer): string;
  begin
    if Size >= $F4240 then
      Result := Format('%.2f', [Size / $F4240]) + ' Mb'
    else
    if Size < 1000 then
      Result := IntToStr(Size) + ' bytes'
    else
      Result := Format('%.2f', [Size / 1000]) + ' Kb';
  end;

const
  READ_BUFFERSIZE = 4096;  // or 256, 512, ...
var
  hNet, hFTP, hFile: HINTERNET;
  buffer: array[0..READ_BUFFERSIZE - 1] of Char;
  bufsize, dwBytesRead, fileSize: DWORD;
  sRec: TWin32FindData;
  strStatus: string;
  LocalFile: file;
  bSuccess: Boolean;
begin
  Result := False;

  { Open an internet session }
  hNet := InternetOpen('Program_Name', // Agent
                        INTERNET_OPEN_TYPE_PRECONFIG, // AccessType
                        nil,  // ProxyName
                        nil, // ProxyBypass
                        0); // or INTERNET_FLAG_ASYNC / INTERNET_FLAG_OFFLINE

  {
    Agent contains the name of the application or
    entity calling the Internet functions
  }

  { See if connection handle is valid }
  if hNet = nil then
  begin
    ShowMessage('Unable to get access to WinInet.Dll');
    Exit;
  end;

  { Connect to the FTP Server }
  hFTP := InternetConnect(hNet, // Handle from InternetOpen
                          PChar(strHost), // FTP server
                          port, // (INTERNET_DEFAULT_FTP_PORT),
                          PChar(StrUser), // username
                          PChar(strPwd),  // password
                          INTERNET_SERVICE_FTP, // FTP, HTTP, or Gopher?
                          0, // flag: 0 or INTERNET_FLAG_PASSIVE
                          0);// User defined number for callback

  if hFTP = nil then
  begin
    InternetCloseHandle(hNet);
    ShowMessage(Format('Host "%s" is not available',[strHost]));
    Exit;
  end;

  { Change directory }
  bSuccess := FtpSetCurrentDirectory(hFTP, PChar(ftpDir));

  if not bSuccess then
  begin
    InternetCloseHandle(hFTP);
    InternetCloseHandle(hNet);
    ShowMessage(Format('Cannot set directory to %s.',[ftpDir]));
    Exit;
  end;

  { Read size of file }
  if FtpFindFirstFile(hFTP, PChar(ftpFile), sRec, 0, 0) <> nil then
  begin
    fileSize := sRec.nFileSizeLow;
    // fileLastWritetime := sRec.lastWriteTime
  end else
  begin
    InternetCloseHandle(hFTP);
    InternetCloseHandle(hNet);
    ShowMessage(Format('Cannot find file ',[ftpFile]));
    Exit;
  end;

  { Open the file }
  hFile := FtpOpenFile(hFTP, // Handle to the ftp session
                       PChar(ftpFile), // filename
                       GENERIC_READ, // dwAccess
                       FTP_TRANSFER_TYPE_BINARY, // dwFlags
                       0); // This is the context used for callbacks.

  if hFile = nil then
  begin
    InternetCloseHandle(hFTP);
    InternetCloseHandle(hNet);
    Exit;
  end;

  { Create a new local file }
  AssignFile(LocalFile, TargetFile);
  {$i-}
  Rewrite(LocalFile, 1);
  {$i+}

  if IOResult <> 0 then
  begin
    InternetCloseHandle(hFile);
    InternetCloseHandle(hFTP);
    InternetCloseHandle(hNet);
    Exit;
  end;

  dwBytesRead := 0;
  bufsize := READ_BUFFERSIZE;

  while (bufsize > 0) do
  begin
    Application.ProcessMessages;

    if not InternetReadFile(hFile,
                            @buffer, // address of a buffer that receives the data
                            READ_BUFFERSIZE, // number of bytes to read from the file
                            bufsize) then Break; // receives the actual number of bytes read

    if (bufsize > 0) and (bufsize <= READ_BUFFERSIZE) then
      BlockWrite(LocalFile, buffer, bufsize);
    dwBytesRead := dwBytesRead + bufsize;

    { Show Progress }
    ProgressBar.Position := Round(dwBytesRead * 100 / fileSize);
    Form1.Label1.Caption := Format('%s of %s / %d %%',[FmtFileSize(dwBytesRead),FmtFileSize(fileSize) ,ProgressBar.Position]);
  end;

  CloseFile(LocalFile);

  InternetCloseHandle(hFile);
  InternetCloseHandle(hFTP);
  InternetCloseHandle(hNet);
  Result := True;
end;

Взято с сайта

Как загрузить HTML код непосредственно в TWebbrowser?

uses
  ActiveX;

procedure WB_LoadHTML(WebBrowser: TWebBrowser; HTMLCode: string);
var
  sl: TStringList;
  ms: TMemoryStream;
begin
  WebBrowser.Navigate('about:blank');
  while WebBrowser.ReadyState < READYSTATE_INTERACTIVE do
   Application.ProcessMessages;

  if Assigned(WebBrowser.Document) then
  begin
    sl := TStringList.Create;
    try
      ms := TMemoryStream.Create;
      try
        sl.Text := HTMLCode;
        sl.SaveToStream(ms);
        ms.Seek(0, 0);
        (WebBrowser.Document as IPersistStreamInit).Load(TStreamAdapter.Create(ms));
      finally
        ms.Free;
      end;
    finally
      sl.Free;
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  WB_LoadHTML(WebBrowser1,'SwissDelphiCenter');
end;

Взято с сайта

Как загрузить иконку CD-ROM?

function GetCDIcon(Drive: Char): TIcon;
var
  ico: TIcon;
  ini: TIniFile;
  s, p: string;
  i, j: Integer;
begin
  //Abbrechen wenn "AutoRun.Inf" nicht existiert.
  //Abort if "AutoRun.inf" doesn't exists.
  if FileExists(Drive + ':\autorun.inf') = False then Exit;

  //"AutoRun.inf" offnen
  //Opens the "AutoRun.inf"
  ini := TIniFile.Create(Drive + ':\autorun.inf');
  ico := TIcon.Create;

  try
    //Dateinamen lesen
    //Read the filename
    s := ini.ReadString('Autorun', 'ICON', '');

    //Abbrechen, wenn kein Icon festgelegt wurde
    //Abort if there is no icon specified
    if s = '' then Exit;

    //Icon von Datei laden
    //load the icon from a file
    if FileExists(s) then ico.LoadFromFile(s);
    if FileExists(Drive + ':\' + s) then ico.LoadFromFile(Drive + ':\' + s);

    //Icon aus einer Resource laden
    //Load the icon from a Win32 resource
    if (FileExists(s) = False) and (FileExists(Drive + ':\' + s) = False) then
    begin
      for j := (Pos(',', s) + 1) to Length(s) do
      begin
        p := p + s[j];
      end;
      i := StrToInt(p);
      for j := Length(s) downto (Pos(',', s)) do
        Delete(s, j, Length(s));

      if FileExists(s) = False then s := Drive + ':\' + s;

      ico.Handle := ExtractIcon(hinstance, PChar(s), i);
    end;

    Result := ico;
  finally
    ini.Free;
  end;
end;

Взято с сайта

Как загрузить юникоды в мемо?

procedureLoadUnicodeFile(const filename: string; strings: TStrings);

  procedure SwapWideChars(p: PWideChar);
  begin
    while p^ <> #0000 do
    begin
      p^ := WideChar(Swap(Word(p^)));
      Inc(p);
    end;
  end;

var
  ms: TMemoryStream;
  wc: WideChar;
  pWc: PWideChar;
begin
  ms := TMemoryStream.Create;
  try
    ms.LoadFromFile(filename);
    ms.Seek(0, soFromend);
    wc := #0000;
    ms.Write(wc, sizeof(wc));
    pWC := ms.Memory;
    if pWc^ = #$FEFF then {normal byte order mark}
      Inc(pWc)
    else if pWc^ = #$FFFE then
    begin {byte order is big-endian}
      SwapWideChars(pWc);
      Inc(pWc);
    end
    else
      ; {no byte order mark}
    strings.Text := WideChartoString(pWc);
  finally
    ms.free;
  end;
end;

Использовать

LoadUnicodeFile(filename, memo1.lines);

Взято с

Delphi Knowledge Base

Как загрузить потоковые(stream) данные в WebBrowser не прибегая к открытию файла?

Взято из FAQ:
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

function TForm1.LoadFromStream(const AStream: TStream): HRESULT;
begin
AStream.seek(0, 0);
Result := (WebBrowser1.Document as
IPersistStreamInit).Load(TStreamAdapter.Create(AStream));
end;

Автор: Per Larsen

Как загрузить строковые данные в WebBrowser не прибегая к открытию файла?

Взято из FAQ:
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Загрузите строку массив Variant, а затем запишите в документ (Document):

...
var
  v: Variant;
  HTMLDocument: IHTMLDocument2;
begin
  HTMLDocument := WebBrowser1.Document as IHTMLDocument2;
  v := VarArrayCreate([0, 0], varVariant);
  v[0] := HTMLString; // Это Ваша HTML строка
  HTMLDocument.Write(PSafeArray(TVarData(v).VArray));
  HTMLDocument.Close; ...
end;
...

Как захватить весь вывод в консоли?

unit consoleoutput;

interface

uses
  Controls, Windows, SysUtils, Forms;

function GetDosOutput(const CommandLine:string): string;

implementation

function GetDosOutput(const CommandLine:string): string;
var
  SA: TSecurityAttributes;
  SI: TStartupInfo;
  PI: TProcessInformation;
  StdOutPipeRead, StdOutPipeWrite: THandle;
  WasOK: Boolean;
  Buffer: array[0..255] of Char;
  BytesRead: Cardinal;
  WorkDir, Line: String;
begin
  Application.ProcessMessages;
  with SA do
  begin
    nLength := SizeOf(SA);
    bInheritHandle := True;
    lpSecurityDescriptor := nil;
  end;
  // создаём пайп для перенаправления стандартного вывода
  CreatePipe(StdOutPipeRead,  // дескриптор чтения
             StdOutPipeWrite, // дескриптор записи
             @SA,              // аттрибуты безопасности
             0                // количество байт принятых для пайпа - 0 по умолчанию
             );
  try
    // Создаём дочерний процесс, используя StdOutPipeWrite в качестве стандартного вывода,
    // а так же проверяем, чтобы он не показывался на экране.
    with SI do
    begin
      FillChar(SI, SizeOf(SI), 0);
      cb := SizeOf(SI);
      dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
      wShowWindow := SW_HIDE;
      hStdInput := GetStdHandle(STD_INPUT_HANDLE); // стандартный ввод не перенаправляем
      hStdOutput := StdOutPipeWrite;
      hStdError := StdOutPipeWrite;
    end;

    // Запускаем компилятор из командной строки
    WorkDir := ExtractFilePath(CommandLine);
    WasOK := CreateProcess(nil, PChar(CommandLine), nil, nil, True, 0, nil, PChar(WorkDir), SI, PI);

    // Теперь, когда дескриптор получен, для безопасности закрываем запись.
    // Нам не нужно, чтобы произошло случайное чтение или запись.
    CloseHandle(StdOutPipeWrite);
    // если процесс может быть создан, то дескриптор, это его вывод
    if not WasOK then
      raise Exception.Create('Could not execute command line!')
    else
      try
        // получаем весь вывод до тех пор, пока DOS-приложение не будет завершено
        Line := '';
        repeat
          // читаем блок символов (могут содержать возвраты каретки и переводы строки)
          WasOK := ReadFile(StdOutPipeRead, Buffer, 255, BytesRead, nil);

          // есть ли что-нибудь ещё для чтения?
          if BytesRead > 0 then
          begin
            // завершаем буфер PChar-ом
            Buffer[BytesRead] := #0;
            // добавляем буфер в общий вывод
            Line := Line + Buffer;
          end;
        until not WasOK or (BytesRead = 0);
        // ждём, пока завершится консольное приложение
        WaitForSingleObject(PI.hProcess, INFINITE);
      finally
        // Закрываем все оставшиеся дескрипторы
        CloseHandle(PI.hThread);
        CloseHandle(PI.hProcess);
      end;
  finally
      result:=Line;
      CloseHandle(StdOutPipeRead);
  end;
end;

end.

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

Как закрыть help при закрытии приложения?

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Application.HelpCommand(HELP_QUIT, 0);
end;

Взято с сайта

procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Winhelp(Handle, 'WINHELP.HLP', HELP_QUIT, 0);
  Action := caFree;
end;

Как закрыть всплывающее меню в System Tray когда оно теряет фокус?

Иногда, при потере фокуса, всплывающее меню в System Tray при потере фокуса не закрывается. Поэтому, при обработке сообщений для всплывающего меню необходимо поместить окно на передний план и послать ему сообщение WM_NULL.

procedure TForm1.WndProc(var Msg : TMessage);
var
  p : TPoint;
begin
  case Msg.Msg of
    WM_USER + 1:
    case Msg.lParam of
      WM_RBUTTONDOWN: begin
         SetForegroundWindow(Handle);
         GetCursorPos(p);
         PopupMenu1.Popup(p.x, p.y);
         PostMessage(Handle, WM_NULL, 0, 0);
      end;
    end;
  end;
  inherited;
end;

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

Как заменить строку в матрице

programMatrices;

{$APPTYPE CONSOLE}

uses
  SysUtils;

type
  TMatrixRow = Array of Double;  {preferrable to Real}
  TMatrix = Array of TMatrixRow;

procedure MatrixExchangeRows(M: TMatrix; First, Second: Integer);
var
  Help: TMatrixRow;
begin
  if (First < 0) or (First > High(M)) or (Second < 0) or (Second > High(M)) then
    Exit;  {or whatever you like.}
  {Only pointers are exchanged!}
  Help := M[First];
  M[First] := M[Second];
  M[Second] := Help;
end;

procedure MatrixWrite(M: TMatrix);
var
  Row, Col: Integer;
begin
  for Row := 0 to High(M) do
  begin
    for Col := 0 to High(M[Row]) do
      Write(M[Row, Col]:10:2);
    Writeln;
  end;
  Writeln;
end;

var
  Matrix: TMatrix;
  Row, Column: Integer;

begin
  Randomize;
  SetLength(Matrix, 4, 4);
  for Row := 0 to High(Matrix) do
    for Column := 0 to High(Matrix[Row]) do
      Matrix[Row, Column] := Random * 1000.0;
  MatrixWrite(Matrix);
  MatrixExchangeRows(Matrix, 1, 2);
  MatrixWrite(Matrix);
  Readln;
end.

Взято из

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

{
  This function starts a hidden word instance, opens a specified document "ADocument"
  and replaces (all) occurrences of "SearchString" with a specified "ReplaceString".
  The function is similar to the Delphi StringReplace() function.
}

uses
  ComObj;

// Replace Flags
type
  TWordReplaceFlags = set of (wrfReplaceAll, wrfMatchCase, wrfMatchWildcards);

function Word_StringReplace(ADocument: TFileName; SearchString, ReplaceString: string; Flags: TWordReplaceFlags): Boolean;
const
  wdFindContinue = 1;
  wdReplaceOne = 1;
  wdReplaceAll = 2;
  wdDoNotSaveChanges = 0;
var
  WordApp: OLEVariant;
begin
  Result := False;

  { Check if file exists }
  if not FileExists(ADocument) then
  begin
    ShowMessage('Specified Document not found.');
    Exit;
  end;

  { Create the OLE Object }
  try
    WordApp := CreateOLEObject('Word.Application');
  except
    on E: Exception do
    begin
      E.Message := 'Word is not available.';
      raise;
    end;
  end;

  try
    { Hide Word }
    WordApp.Visible := False;
    { Open the document }
    WordApp.Documents.Open(ADocument);
    { Initialize parameters}
    WordApp.Selection.Find.ClearFormatting;
    WordApp.Selection.Find.Text := SearchString;
    WordApp.Selection.Find.Replacement.Text := ReplaceString;
    WordApp.Selection.Find.Forward := True;
    WordApp.Selection.Find.Wrap := wdFindContinue;
    WordApp.Selection.Find.Format := False;
    WordApp.Selection.Find.MatchCase := wrfMatchCase in Flags;
    WordApp.Selection.Find.MatchWholeWord := False;
    WordApp.Selection.Find.MatchWildcards := wrfMatchWildcards in Flags;
    WordApp.Selection.Find.MatchSoundsLike := False;
    WordApp.Selection.Find.MatchAllWordForms := False;
    { Perform the search}
    if wrfReplaceAll in Flags then
      WordApp.Selection.Find.Execute(Replace := wdReplaceAll)
    else
      WordApp.Selection.Find.Execute(Replace := wdReplaceOne);
    { Save word }
    WordApp.ActiveDocument.SaveAs(ADocument);
    { Assume that successful }
    Result := True;
    { Close the document }
    WordApp.ActiveDocument.Close(wdDoNotSaveChanges);
  finally
    { Quit Word }
    WordApp.Quit;
    WordApp := Unassigned;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Word_StringReplace('C:\Test.doc','Old String','New String',[wrfReplaceAll]);
end;

Взято с сайта

Как заменить значение переменных для текста MS Word?

uses
Office97; {or Office2000, OfficeXP, Office_TLB}

var
  VDoc, PropName, DocName: OleVariant;
  VDoc := Word.ActiveDocument;
  { ... }

{ Set a document property }
PropName := 'MyOpinionOfThisDocument';
VDoc.CustomDocumentProperties.Add(PropName, False, msoPropertyTypeString,
  'Utter drivel', EmptyParam);
{ Read a document property }
Caption := VDoc.CustomDocumentProperties[PropName].Value;
{ ... }

Взято с

Delphi Knowledge Base

Как записать CDR/CDRW?

К сожалению, реальных примеров пока не найдено, а литература в сети крайне скудна по этому поводу. Вот список линков по которым удалось хоть что-то найти:

1) на torry есть компонент
(только для WindowsXP)

2)

3)

Убедительная просьба, если кто располагает информацией о записи на CD поделиться - бросить либо в форум, либо мне на почту

Взято с Vingrad.ru

Как записать файл в Blob поле?

1)Через таблицу:

(table1.fieldbyname('ddd') as TBlobField).loadfromfile('dddss');

(Для некоторых баз данных через BDE так можно загрузить не более 64k)

2) через параметры в квере...

ADOquery1.sql.text:='Insert into myTable (a) Values (:b)';
ADOQuery1.parameters.parseSQL(ADOquery1.sql.text, true);
ADOQuery1.parameters.parambyname('b').LoadFromFile('MyFile');
ADOQuery1.execsql;

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

Как записать в BLOB поле большой текст (более 255)?

var
S: TBlobStream;
  B: pointer;
  c: integer;

...

  Table1.Edit;
  S := TBlobStream.Create(Table1BlobField as TBlobField, bmWrite); {кажется, так}
  C := S.write(B, C);
  Table1.Post;
  S.Destroy;

или так

var
  S: TMemoryStream;
  B: pointer;
  C: integer;

...

S := TMemoryStream.Create;

...

  Table1.Edit;
  S.Clear;
  S.SetSize(C);
  C := S.write(B,C);
  (Table1BlobField as TBlobField).LoadFromStream(S);
  S.Clear;
  Table1.Post;

...

S.Destroy;

Взято из

Как заполнить поля формы в MS Word?

uses
  ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  WordApp: OLEvariant;
begin
  Screen.Cursor := crHourglass;
  try
    // Create Word Instance
    WordApp := CreateOleObject('Word.Application');
  except
    ShowMessage('Cannot start MS Word.');
    Screen.Cursor := crDefault;
    Exit;
  end;

  try
    // Open a Word Document
    WordApp.Documents.Add(Template := 'C:\TestDoc.doc');

    // Show Word
    WordApp.Visible := True;

    // Check if FormField exists and asign your text
    if WordApp.ActiveDocument.Bookmarks.Exists('YourFormFieldName') then
      WordApp.ActiveDocument.FormFields.Item('YourFormFieldName').Result := 'Your Text';
  finally
    WordApp := Unassigned;
    Screen.Cursor := crDefault;
  end;
end;

Взято с сайта

Как запретить Ctrl-Alt-Del?

var
i : integer;
begin
i := 0;
{запрещаем Ctrl-Alt-Del}
SystemParametersInfo( SPI_SCREENSAVERRUNNING, 1, @i, 0);
end.
// необходим unit WinProcs
// для Alt-Tab: SPI_SETFASTTASKSWITCH

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

Как запретить кнопку close в любом окне?

Следующий пример запрещает кнопку закрытия (и пункт "закрыть" (close) в системном меню) нужного нам окна (в данном случае Notepad).

procedure TForm1.Button1Click(Sender: TObject);
var
  hwndHandle : THANDLE;
  hMenuHandle : HMENU;
begin
  hwndHandle := FindWindow(nil, 'Untitled - Notepad');
  if (hwndHandle <> 0) then begin
    hMenuHandle := GetSystemMenu(hwndHandle, FALSE);
    if (hMenuHandle <> 0) then
      DeleteMenu(hMenuHandle, SC_CLOSE, MF_BYCOMMAND);
  end;
end;

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