[Оглавление]   [1]  [2]  [3]  [4]  [5]  [6]  [7]

Windows API & Delphi VCL FAQ

Часть 4

Предположим, что процесс создаем мы, ожидая его завершения в течение maxworktime. Тогда

var
  dwResult: Longint; // This example was converted from C source.
begin                // Not tested. Some 'nil' assignments must be applied
                     // as zero assignments in Pascal. Some vars need to
                     // be declared (maxworktime, si, pi). AA.
  if CreateProcess(nil, CmdStr, nil, nil, FALSE,
                              CREATE_NEW_CONSOLE, nil, nil, si, pi) then
  begin
    CloseHandle( pi.hThread );
    dwResult := WaitForSingleObject(pi.hProcess, maxworktime*1000*60);
    CloseHandle( pi.hProcess );
    if dwResult <> WAIT_OBJECT_0 then
    begin
      pi.hProcess := OpenProcess(PROCESS_TERMINATE, FALSE, pi.dwProcessId);
      if pi.hProcess <> nil then
      begin
          TerminateProcess(pi.hProcess, 0);
          CloseHandle(pi.hProcess);
      end;
    end;
  end;
end;

program del;

uses
 ShellApi;

//function SHFileOperation(const lpFileOp: TSHFileOpStruct): Integer; stdcall;

Var T:TSHFileOpStruct;
    P:String;
begin
  P:='C:\Windows\System\EL_CONTROL.CPL';
  With T do
  Begin
    Wnd:=0;
    wFunc:=FO_DELETE;
    pFrom:=Pchar(P);
    fFlags:=FOF_ALLOWUNDO
  End;
  SHFileOperation(T);
End.

  procedure TMyForm.CreateParams(var Params :TCreateParams); {override;}
  begin
    inherited CreateParams(Params); {CreateWindowEx}
    Params.ExStyle := Params.ExStyle or WS_Ex_AppWindow;
  end;

 DefaultDrawing:=False;
 ....
procedure TfrmCard.GridDrawColumnCell(Sender: TObject; const Rect: TRect;
                                          DataCol: Integer; Column: TColumn;
                                          State: TGridDrawState);
var
  Index   : Integer;
  Marked,
  Selected: Boolean;
begin

  Marked := False;
  if (dgMultiSelect in Grid.Options) and THackDBGrid(Grid).Datalink.Active then
    Marked
:=Grid.SelectedRows.Find(THackDBGrid(Grid).Datalink.Datasource.Dataset.Bookmark
, Index);

  Selected := THackDBGrid(Grid).Datalink.Active and (Grid.Row-1 =
                                THackDBGrid(Grid).Datalink.ActiveRecord);

  if Marked then begin
    Grid.Canvas.Brush.Color:=$DFEFDF;;
    Grid.Canvas.Font.Color :=clBlack;
  end;

  if Selected then begin
    Grid.Canvas.Brush.Color:=$FFFBF0;
    Grid.Canvas.Font.Color :=clBlack;
    if Marked then
      Grid.Canvas.Brush.Color:=$EFE3DF; { $8F8A30 }
  end;

  Grid.DefaultDrawColumnCell(Rect, DataCol, Column, State);
end;

  THackDBGrid = class(TDBGrid)
    property DataLink;
    property UpdateLock;
  end;

// Routine: check if the user has administrator provileges
// Was converted from C source by Akzhan Abdulin. Not properly tested.
type
 PTOKEN_GROUPS = TOKEN_GROUPS^;

function RunningAsAdministrator (): Boolean;
var
 SystemSidAuthority: SID_IDENTIFIER_AUTHORITY = SECURITY_NT_AUTHORITY;
 psidAdmin: PSID;
 ptg: PTOKEN_GROUPS = nil;
 htkThread: Integer; { HANDLE }
 cbTokenGroups: Longint; { DWORD }
 iGroup: Longint; { DWORD }
 bAdmin: Boolean;

begin
    Result := false;
    if not OpenThreadToken(GetCurrentThread(),      // get security token
                        TOKEN_QUERY,
                        FALSE,
                        htkThread) then
       if GetLastError() = ERROR_NO_TOKEN then
       begin
          if not OpenProcessToken(GetCurrentProcess(),
                               TOKEN_QUERY,
                               htkThread) then
          Exit;
       end
       else
          Exit;
    if GetTokenInformation(htkThread,            // get #of groups
                           TokenGroups,
                           nil,
                           0,
                           cbTokenGroups) then
       Exit;
    if GetLastError() <> ERROR_INSUFFICIENT_BUFFER then
       Exit;
    ptg := PTOKEN_GROUPS( getmem( cbTokenGroups ) );
    if not Assigned(ptg) then
       Exit;
    if not GetTokenInformation(htkThread,           // get groups
                            TokenGroups,
                            ptg,
                            cbTokenGroups,
                            cbTokenGroups) then
       Exit;
    if not AllocateAndInitializeSid(SystemSidAuthority,
                                 2,
                                 SECURITY_BUILTIN_DOMAIN_RID,
                                 DOMAIN_ALIAS_RID_ADMINS,
                                 0, 0, 0, 0, 0, 0,
                                 psidAdmin) then
       Exit;
    iGroup := 0;
    while iGroup < ptg^.GroupCount do // check administrator group
    begin
       if EqualSid(ptg^.Groups[iGroup].Sid, psidAdmin) then
       begin
          Result := TRUE;
          break;
       end;
       Inc( iGroup );
    end;
    FreeSid(psidAdmin);
end;

procedure TMainForm.stStatusBarDrawPanel(StatusBar: TStatusBar;
  Panel: TStatusPanel; const Rect: TRect);
begin
  if Panel.Index = pnProgress then
  begin
    pgProgress.BoundsRect := Rect;
    pgProgress.PaintTo(stStatusBar.Canvas.Handle, Rect.Left, Rect.Top);
  end;
end;

procedure FNTimeCallBack(uTimerID, uMessage: UINT;dwUser, dw1, dw2: DWORD)
stdcall;
begin
//
//  Тело процедуры.
end;

Подробности смотри в Help.
Hу и в конце убиваешь таймер
timeKillEvent(uTimerID);

И все. Точность этого способа до 1 мсек. минимальный интервал времени можно задавать 1 мсек.

Если Вы передаете в качестве размера 0, то ОС ограничивает размер OS Specific Default Value. Реально, по результатам моих экспериментов, поставить можно размер, чуть меньший доступной виртуальной памяти. Я ограничился 90% от свободной виртуалки.

Для того, чтобы не повторять этот вызов (EM_LIMITTEXT), можно воспользоваться сообщением EM_EXLIMITTEXT.

{$IFDEF WIN32}
    AddFontResource( PChar( my_font_PathName { AnsiString } ) );
{$ELSE}
var
    ss  : array [ 0..255 ] of Char;

    AddFontResource ( StrPCopy ( ss, my_font_PathName ));
{$ENDIF}
    SendMessage ( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 );

{$IFDEF WIN32}
    RemoveFontResource ( PChar(my_font_PathName) );
{$ELSE}
    RemoveFontResource ( StrPCopy ( ss, my_font_PathName ));
{$ENDIF}
    SendMessage ( HWND_BROADCAST, WM_FONTCHANGE, 0, 0 );

Function RoundStr(Zn:Real;kol_zn:Integer):Real;
{Zn-значение;  Kol_Zn-_ол-во знаков после запятой}
Var snl,s,s0,s1,s2:String; n,n1:Real; nn,i:Integer;
begin
 s:=FloatToStr(Zn);
 if (Pos(',',s)>0) and (Zn>0) and
    (Length(Copy(s,Pos(',',s)+1,length(s)))>kol_zn)
 then begin
   s0:=Copy(s,1,Pos(',',s)+kol_zn-1);
   s1:=Copy(s,1,Pos(',',s)+kol_zn+2);
   s2:=Copy(s1,Pos(',',s1)+kol_zn,Length(s1));
   n:=StrToInt(s2)/100; nn:=Round(n);
   if nn>=10 then begin
     snl:='0,';  For i:=1 to kol_zn-1 do snl:=snl+'0'; snl:=snl+'1';
     n1:=StrToFloat(Copy(s,1,Pos(',',s)+kol_zn))+StrToFloat(snl);
     s:=FloatToStr(n1); if Pos(',',s)>0 then s1:=Copy(s,1,Pos(',',s)+kol_zn);
   end else s1:=s0+IntToStr(nn);
   if s1[Length(s1)]=',' then s1:=s1+'0';
   Result:=StrToFloat(s1);
 end else Result:=Zn;
end;

Все-таки работа со строками здесь излишество -

function RoundEx( X: Double; Precision : Integer ): Double;
{Precision :
1   - до целых
10  - до десятых
100 - до сотых
...
}
var  ScaledFractPart, Temp : Double;
begin
  ScaledFractPart := Frac(X)*Precision;
  Temp := Frac(ScaledFractPart);
  ScaledFractPart := Int(ScaledFractPart);
  if Temp >=  0.5 then ScaledFractPart := ScaledFractPart + 1;
  if Temp <= -0.5 then ScaledFractPart := ScaledFractPart - 1;
  RoundEx := Int(X) + ScaledFractPart/Precision;
end;

function TMyForm.Execute: TModalResult;
begin
  Show;
  try
    SendMessage(Handle, CM_ACTIVATE, 0, 0);
    ModalResult := 0;
    repeat
      Application.HandleMessage;
      if Application.Terminated then ModalResult := mrCancel;
      if ModalResult = mrCancel then CloseModal;
    until ModalResult <> 0;
    Hide;
    Result := ModalResult;
    SendMessage(Handle, CM_DEACTIVATE, 0, 0);
  finally
    Hide;
  end;
end;

BOOL Ctrl_Handler( DWORD Ctrl )
{
    if(    (Ctrl == CTRL_SHUTDOWN_EVENT)
        || (Ctrl == CTRL_LOGOFF_EVENT)
      )
    {
        // Вау! Юзер обламывает!
    }
    else
    {
        // Тут что-от другое можно творить. А можно и не творить :-)
    }
    return TRUE;
}

function Ctrl_Handler(Ctrl: Longint): LongBool;
begin
 if Ctrl in [CTRL_SHUTDOWN_EVENT, CTRL_LOGOFF_EVENT] then
 begin
  // Вау, вау
 end
 else
 begin
  // Am I creator?
 end;
 Result := true;
end;

А где-то в программе: SetConsoleCtrlHandler( Ctrl_Handler, TRUE );

Таких обработчиков можно навесить кучу. Если при обработке какого-то из сообщений обработчик возвращет FALSE, то вызывается следующий обработчик. Можно насторить таких этажерок, что ого-го :-)))

Короче, смотри описание SetConsoleCtrlHandler -- там всё есть.

  StrPCopy(buff,Edit1.Text);
  fPipeHandle:=CreateNamedPipe(buff,
    Pipe_Access_Duplex or File_Flag_Overlapped,
    Pipe_Type_Message or Pipe_ReadMode_Byte or Pipe_Wait,
    5, $400, $400, 235, nil);

  StrPCopy(buff,Edit1.Text);
  fFileHandle:=CreateFile(buff,
    Generic_Read or Generic_Write,
    File_Share_Read or File_Share_Write,
    nil,
    Open_Existing,
    File_Attribute_Normal or File_Flag_Overlapped or Security_Anonymous,
    0);
  if fFileHandle <> Invalid_Handle_Value then begin ...

bool old;
SystemParametersInfo (SPI_SCREENSAVERRUNNING,1,&old,0)

SystemparametersInfo (SPI_ScreenSaverrunning,0,&old,0)

Мне помогло. Хоть и пpишлось повозиться: в хэлпе нет пpо паpаметp SPI_SCRENSAVERRUNNING...

unit DN_Win;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, Menus, StdCtrls,

type
  TDNForm = class(TForm)
    MainMenu1: TMainMenu;
    cm_MainExit: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure cm_MainExitClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    BM:TBitmap;
    Procedure WMDrawItem(var Msg:TWMDrawItem);      message wm_DrawItem;
    Procedure WMMeasureItem(var Msg:TWMMeasureItem); message
wm_MeasureItem;

  end;

var
  DNForm : TDNForm;

implementation

{$R *.DFM}

var
  Comm,yMenu : word;

procedure TDNForm.FormCreate(Sender: TObject);
begin
  {картинку в меню}
  yMenu:=GetSystemMetrics(SM_CYMENU);
  comm:=cm_MainExit.Command;
  ModifyMenu(MainMenu1.Handle,0,mf_ByPosition or mf_OwnerDraw,comm,'Go');
end;{TDNForm.FormCreate}

procedure TDNForm.cm_MainExitClick(Sender: TObject);
begin
  DNForm.Close;
end;{TDNForm.cmExitClick}

{для прорисовки меню}
Procedure TDNForm.WMMeasureItem(var Msg:TWMMeasureItem);
Begin
with Msg.MeasureItemStruct^ do
  if ItemID=comm then  begin ItemWidth:=yMenu; Itemheight:=yMenu; end;
End;{WMMeasureItem}
{}
Procedure TDNForm.WMDrawItem(var Msg:TWMDrawItem);
var
  MemDC:hDC;
  BM:hBitMap;
  mtd:longint;
Begin
with Msg.DrawItemStruct^ do
  begin
  if ItemID=comm then
    begin
      BM:=LoadBitMap(hInstance,'dver');
      MemDC:=CreateCompatibleDC(hDC);{hDC входит в структуру
TDrawItemStruct}
      SelectObject(MemDC,BM);
      {rcItem входит в структуру TDrawItemStruct}
      if ItemState=ods_Selected then mtd:=NotSrcCopy  else mtd:=SrcCopy;

StretchBlt(hDC,rcItem.left,rcItem.top,yMenu,yMenu,MemDC,0,0,24,23,mtd);
      DeleteDC(MemDC);
      DeleteObject(BM);
    end;
  end{with}
End;{TDNForm.WMDrawItem}

end.