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

Windows API & Delphi VCL FAQ

Часть 1

procedure FlushIni(FileName: string);
var
  {$IFDEF WIN32}
  CFileName: array[0..MAX_PATH] of WideChar;
  {$ELSE}
  CFileName: array[0..127] of Char;
  {$ENDIF}
begin
  {$IFDEF WIN32}
  if (Win32Platform = VER_PLATFORM_WIN32_NT) then
    WritePrivateProfileStringW(nil, nil, nil, StringToWideChar(FileName,
    CFileName, MAX_PATH))
  else
    WritePrivateProfileString(nil, nil, nil, PChar(FileName));
  {$ELSE}
  WritePrivateProfileString(nil, nil, nil, StrPLCopy(CFileName,
    FileName, SizeOf(CFileName) - 1));
  {$ENDIF}
end;

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
            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.

  
  bt := TBitmap.Create;
  bt.Width := gr.Width;
  bt.Height := gr.Height;
  bt.Canvas.CopyRect(ClientRect, gr.Canvas, gr.ClientRect);
  bt.SaveToFile('e:\bt.bmp');
  bt.Free;

procedure ShowAlmostModal(FormModal:TForm);
begin
 NavigatorForm.Enabled:=false;
 FormModal.ShowModal
end;

procedure FormShow(Sender:Tobject);
begin
 NavigatorForm.Enabled:=true;
end;

1. берется проект, компилируется
2. тут-же не закрывая проект вызвается New|Resource DLL Wizard в нем указывается какие формы и модули должны подвергнуться переводу на другой язык.
3. в результате работы Wizard появляется проект (!) с RC и DFM. Открываем формы, и переделываем все сообщения + размер (соотв. длине сообщений). Компилируем. В результате получается файл xxxxxxx.rus, где xxxxxxx - название исходного проекта.
4. Запускаем xxxxxxx.exe. Видим некий не наш язык. Подкладываем в каталог с этим exe изготовленный файл xxxxxxx.rus, и запускаем exe повторно. Видим абсолютно ВЕЗДЕ переведенные сообщения.

p.s. файл RUS можно подставлять и убирать по вкусу.

unit edit1;

interface

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

type
  TPopupListbox = class(TCustomListbox)
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
override;
  end;

  TTestDropEdit = class(TEdit)
  private
    FPickList: TPopupListbox;
    procedure CMCancelMode(var Message: TCMCancelMode); message CM_CancelMode;
    procedure WMKillFocus(var Message: TMessage); message WM_KillFocus;
  protected
    procedure CloseUp(Accept: Boolean);
    procedure DropDown;
    procedure WndProc(var Message: TMessage); override;
  public
    constructor Create(Owner: TComponent); override;
    destructor Destroy; override;
  end;

implementation

procedure TPopupListBox.CreateParams(var Params: TCreateParams);
begin
  inherited;
  with Params do begin
    Style := Style or WS_BORDER;
    ExStyle := WS_EX_TOOLWINDOW or WS_EX_TOPMOST;
    WindowClass.Style := CS_SAVEBITS;
  end;
end;

procedure TPopupListbox.CreateWnd;
begin
  inherited CreateWnd;
  Windows.SetParent(Handle, 0);
  CallWindowProc(DefWndProc, Handle, WM_SETFOCUS, 0, 0);
end;

procedure TPopupListbox.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);
  TTestDropEdit(Owner).CloseUp((X >= 0) and (Y >= 0) and (X < Width) and (Y <
Height));
end;

{  TTestDropEdit  }
constructor TTestDropEdit.Create(Owner: TComponent);
begin
  inherited Create(Owner);
  Parent := Owner as TWinControl;
  FPickList := TPopupListbox.Create(nil);
  FPickList.Visible := False;
  FPickList.Parent := Self;
  FPickList.IntegralHeight := True;
  FPickList.ItemHeight := 11;
  FPickList.Items.CommaText :='1,2,3,4,5,6,7,8,9,0';
end;

destructor TTestDropEdit.Destroy;
begin
  FPickList.Free;
  inherited;
end;

procedure TTestDropEdit.CloseUp(Accept: Boolean);
begin
  if FPickList.Visible then begin
    if GetCapture <> 0 then SendMessage(GetCapture, WM_CANCELMODE, 0, 0);
    SetWindowPos(FPickList.Handle, 0, 0, 0, 0, 0, SWP_NOZORDER or
      SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_HIDEWINDOW);
    if FPickList.ItemIndex <> -1 then
      Text := FPickList.Items.Strings[FPickList.ItemIndex];
    FPickList.Visible := False;
    Invalidate;
  end;
end;

procedure TTestDropEdit.DropDown;
var
  P: TPoint;
  I,J,Y: Integer;
begin
  if Assigned(FPickList) and (not FPickList.Visible) then begin
    FPickList.Width := Width;
    FPickList.Color := Color;
    FPickList.Font := Font;
    FPickList.Height := 6 * FPickList.ItemHeight + 4;
    FPickList.ItemIndex := FPickList.Items.IndexOf(Text);
    P := Parent.ClientToScreen(Point(Left, Top));
    Y := P.Y + Height;
    if Y + FPickList.Height > Screen.Height then Y := P.Y - FPickList.Height;
    SetWindowPos(FPickList.Handle, HWND_TOP, P.X, Y, 0, 0,
      SWP_NOSIZE or SWP_NOACTIVATE or SWP_SHOWWINDOW);
    FPickList.Visible := True;
    Invalidate;
    Windows.SetFocus(Handle);
  end;
end;

procedure TTestDropEdit.CMCancelMode(var Message: TCMCancelMode);
begin
  if (Message.Sender <> Self) and (Message.Sender <> FPickList) then
    CloseUp(False);
end;

procedure TTestDropEdit.WMKillFocus(var Message: TMessage);
begin
  inherited;
  CloseUp(False);
end;

procedure TTestDropEdit.WndProc(var Message: TMessage);
  procedure DoDropDownKeys(var Key: Word; Shift: TShiftState);
  begin
    case Key of
      VK_UP, VK_DOWN:
        if ssAlt in Shift then begin
          if FPickList.Visible  then CloseUp(True) else DropDown;
          Key := 0;
        end;
      VK_RETURN, VK_ESCAPE:
        if FPickList.Visible  and not (ssAlt in Shift) then begin
          CloseUp(Key = VK_RETURN);
          Key := 0;
        end;
    end;
  end;
begin
  case Message.Msg of
    WM_KeyDown, WM_SysKeyDown, WM_Char:
      with TWMKey(Message) do begin
        DoDropDownKeys(CharCode, KeyDataToShiftState(KeyData));
        if (CharCode <> 0) and FPickList.Visible then begin
          with TMessage(Message) do
            SendMessage(FPickList.Handle, Msg, WParam, LParam);
          Exit;
        end;
      end
  end;
  inherited;
end;

end.

Под Win16 Вы можете использовать функцию SpoolFile, или Passthrough escape, если принтер поддерживает последнее. Под Win32 Вы можете использовать WritePrinter.

Ниже пример открытия принтера и записи чистого потока данных в принтер. Учтите, что Вы должны передать корректное имя принтера, такое, как "HP LaserJet 5MP", чтобы функция сработала успешно.

Конечно, Вы можете включать в поток данных любые необходимые управляющие коды, которые могут потребоваться.

uses WinSpool;

procedure WriteRawStringToPrinter(PrinterName:String; S:String);
var
  Handle: THandle;
  N: DWORD;
  DocInfo1: TDocInfo1;
begin
  if not OpenPrinter(PChar(PrinterName), Handle, nil) then
  begin
    ShowMessage('error ' + IntToStr(GetLastError));
    Exit;
  end;
  with DocInfo1 do begin
    pDocName := PChar('test doc');
    pOutputFile := nil;
    pDataType := 'RAW';
  end;
  StartDocPrinter(Handle, 1, @DocInfo1);
  StartPagePrinter(Handle);
  WritePrinter(Handle, PChar(S), Length(S), N);
  EndPagePrinter(Handle);
  EndDocPrinter(Handle);
  ClosePrinter(Handle);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  WriteRawStringToPrinter('HP', 'Test This');
end;

Посмотри и доделай как тебе надо.

unit TextPrinter;

interface

uses
  Windows, Controls, Forms, Dialogs;

type
  TTextPrinter = class(TObject)
    FNumberOfBytesWritten: Integer;
    FHandle: THandle;
    FPrinterOpen: Boolean;
    FErrorString: PChar;
    procedure SetErrorString;
  public
    constructor Create;
    procedure Write(const Str: string);
    procedure WriteLn(const Str: string);
    destructor Destroy; override;
  published
    property NumberOfBytesWritten: Integer read FNumberOfBytesWritten;
  end;

implementation

{TTextPrinter}

constructor TTextPrinter.Create;
begin
  FHandle := CreateFile('LPT1', GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ
or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
  if FHandle = INVALID_HANDLE_VALUE then
  begin
    SetErrorString;
    raise Exception.Create(FErrorString);
  end
  else
    FPrinterOpen := True;
end;

procedure TTextPrinter.SetErrorString;
begin
  if FErrorString <> nil then
    LocalFree(Integer(FErrorString));
  FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,
                nil,
                GetLastError(),
                LANG_USER_DEFAULT,
                @FErrorString,
                0,
                nil);
end;

procedure TTextPrinter.Write(const Str: string);
var
  OEMStr: PChar;
  NumberOfBytesToWrite: Integer;
begin
  if not FPrinterOpen then
    Exit;
  NumberOfBytesToWrite := Length(Str);
  OEMStr := PChar(LocalAlloc(LMEM_FIXED, NumberOfBytesToWrite + 1));
  try
    CharToOem(PChar(Str), OEMStr);
    if not WriteFile(FHandle, OEMStr^, NumberOfBytesToWrite,
FNumberOfBytesWritten, nil) then
    begin
      SetErrorString;
      raise Exception.Create(FErrorString);
    end;
  finally
    LocalFree(Integer(OEMStr));
  end;
end;

procedure TTextPrinter.WriteLn(const Str: string);
begin
  Self.Write(Str);
  Self.Write(#10);
end;

destructor TTextPrinter.Destroy;
begin
  CloseHandle(FHandle);
  if FErrorString <> nil then
    LocalFree(Integer(FErrorString));
end;

end.

P.S. В принципе, вместо LPT1 может стоять что угодно, даже сетевой сервер печати (\\server\prn) - все равно печатает. Можно и параметр в конструктор вставить и т.д.

При этом регион этот теперь используется Windows и будет уничтожен при закрытии окна.

Попpобуйте вот этот обpаботчик OnCreate

procedure TForm1.FormCreate(Sender: TObject);
const W=36*pi/180;
var   R,R1,R2: HRgn; X,Y,i:integer;

   function S(A:integer;R:integer):integer;
   begin
     Result:=round(R*sin(W*a));
   end;

   function C(A:integer;R:integer):integer;
   begin
     Result:=round(R*cos(W*a));
   end;

   function GetStarReg(X,Y,R:integer):HRGN;
   var  P : array [0..4] of TPoint;
   begin
      P[0] := Point(X, Y-R);
      P[1] := Point(X-S(4,R), Y-C(4,R));
      P[2] := Point(X-S(8,R), Y-C(8,R));
      P[3] := Point(X-S(2,R), Y-C(2,R));
      P[4] := Point(X-S(6,R), Y-C(6,R));
      Result := CreatePolygonRgn(P, 5, WINDING);
   end;

begin
   X:=Width div 2;
   Y:=Height div 2;
   R:=GetStarReg(X,Y,100);
   i:=1;
   repeat
     R1:=GetStarReg(X-S(i,120),Y-C(i,110),40);
     CombineRgn(R,R,R1,RGN_OR);
     inc(i,2);
   until i>9;
   R1:=GetStarReg(X,Y,30);
   CombineRgn(R,R,R1,RGN_DIFF);

   R1:=CreateEllipticRgn(3,3,Width-6,Height-6);
   R2:=CreateEllipticRgn(20,10,Width-20,Height-10);
   CombineRgn(R1,R1,R2,RGN_DIFF);
   CombineRgn(R,R,R1,RGN_OR);

   SetWindowRgn(Handle, R, True);
end;

А дело было так :

 interface

  type

   TMyComp = class(TWinControl)
    ...
   end;

  procedure Register;

 implementation

  procedure Register;
   begin
    RegisterComponents('MyPage', [TMyComp]);
    RegisterPropertyEditor(TypeInfo(String),TMyComp,'Hint',nil);
   end;

 [ и т.д.]

Тепеpь property 'Hint' в Object Inspector не видно. Рад, если чем-то помог. Если будут глюки, умоляю сообшить. Такой подход у меня сплошь и pядом.

type
  PNetResourceArray = ^TNetResourceArray;
  TNetResourceArray =
    array[0..MaxInt div SizeOf(TNetResource) - 1] of TNetResource;

Procedure EnumResources(LpNR:PNetResource);
Var
  NetHandle: THandle;
  BufSize: Integer;
  Size: Integer;
  NetResources: PNetResourceArray;
  Count: Integer;
  NetResult:Integer;
  I: Integer;
  NewItem:TListItem;

Begin
  If WNetOpenEnum(
    RESOURCE_GLOBALNET,
    RESOURCETYPE_ANY,
      // RESOURCETYPE_ANY    - все ресурсы
      // RESOURCETYPE_DISK   - диски
      // RESOURCETYPE_PRINT  - принтеры
    0,
    LpNR,
    NetHandle) <> NO_ERROR then Exit;
  Try
    BufSize := 50 * SizeOf(TNetResource);
    GetMem(NetResources, BufSize);
    Try
      while True do
      begin
        Count := -1;
        Size := BufSize;
        NetResult := WNetEnumResource(NetHandle, Count, NetResources, Size);
        If NetResult = ERROR_MORE_DATA then
        begin
          BufSize := Size;
          ReallocMem(NetResources, BufSize);
          Continue;
        end;
        if NetResult <> NO_ERROR then Exit;
        For I := 0 to Count-1 do
          Begin
            With NetResources^[I] do
              Begin
                If RESOURCEUSAGE_CONTAINER =
                   (DwUsage and RESOURCEUSAGE_CONTAINER) then
                  EnumResources(@NetResources^[I]);

                If dwDisplayType = RESOURCEDISPLAYTYPE_SHARE Then
//                                 ^^^^^^^^^^^^^^^^^^^^^^^^^   - ресурс
//                RESOURCEDISPLAYTYPE_SERVER  - компьютер
//                RESOURCEDISPLAYTYPE_DOMAIN  - рабочая группа
//                RESOURCEDISPLAYTYPE_GENERIC - сеть

                  Begin
                    NewItem:= Form1.ListView1.Items.Add;
                    NewItem.Caption:=LpRemoteName;
                 End;
              End;
          End
      End;
    finally
      FreeMem(NetResources, BufSize);
    end;
  finally
    WNetCloseEnum(NetHandle);
  end;
End;

procedure TForm1.Button1Click(Sender: TObject);
Var
  OldCursor: TCursor;
begin
  OldCursor:= Screen.Cursor;
  Screen.Cursor:= crHourGlass;
  With ListView1.Items do
    Begin
      BeginUpdate;
      Clear;
      EnumResource(nil);
      EndUpdate;
    End;
  Screen.Cursor:= OldCursor;
end;