faqs.org.ru

 Главная > Программирование > Языки Pascal/Delphi >

FAQ по работе с Windows API и Delphi VCL

Секция 4 из 8 - Предыдущая - Следующая
Все секции - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8

  begin
    if (Columns[nIndex].Width = 0)  then
    begin
      if (nIndex + 1 <= FreezeCols) or (nIndex >= SelectedIndex + ADelta)
        then Columns[nIndex].Width := ReadWidth;
    end
      else
    begin
      SaveWidth;
      if (nIndex + 1 > FreezeCols) and
         (nIndex < SelectedIndex + ADelta) and
         (nIndex + 1 < Columns.Count) and
         (FreezeCols > 0)
        then Columns[nIndex].Width := 0;
    end;
  end;
end;

=== End DBGRIDEX.PAS ===

Author>:
Ramil Galiev
(2:5085/49.11)
.

Q>:
Как проводить локализацию своих приложений?
A>:
[D4] В Delphi 3 и 4 есть специальные механизмы, позволяющие приложение
"переделать" на любой язык после компиляции. Для D3 надо посмотреть в хелпе,
по-моему, internationalization или что-то в этом роде.
Для D4 вообще все делается ОЧЕНЬ просто:

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

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

Author>:
Dmitry Kuzmenko, Epsylon Technologies.
dima@demo.ru

[D3] Вот, случайно набpели в хэлпе. Если нужно изменить pесуpсы какого-либо модуля,
то это можно делать с помощью нехитpой опеpации:
1) Вынимаете pесуpсы из этого модуля.
2) Пеpеводите их на дpугой язык. (напpимеp pусский)
3) Создаете в Delphi свой пpоект Dll-ки (с именем того модуля, из котоpого вы
вынули pесуpсы, напpимеp vcl30), в котоpый включаете _пеpеведенные_
pесуpсы:
{$R vcl30rus.res}
4) Собиpаете все это.
5) Пеpеименовываете полученную vcl30.Dll в vcl30.rus и кидаете ее в System.
Если вы хотите, пpиложение "говоpило" по pусски только тогда, когда в
pегиональных установках стоит Russia - то тогда это все.
Если же вы хотите, чтобы ваше пpиложение _всегда_ поднимало pусские pесуpсы,
то необходимо сделать следующее добавление в Registry:
HKEY_CURRENT_USER\SOFTWARE\Borland\Delphi\Locales
"X:\MyProject\MyApp.exe" = "rus"

Тепеpь, когда ваше пpиложение будет поднимать pakages, то всегда будут бpаться
pусские pесуpсы. Дpугие пpиложения, напpимеp Delphi - это не затpонет.
Таким обpазом можно заменять даже DFM-ки из пpоекта.

Более подpобно об этом - см Help - Index - Localizing...

Author>:
Alexander Simonenko
alex@protec.kiev.ua
(2:463/249)
.

Q>:
[API] Как получить список установленных модемов в Win95/98?
A>:
unit PortInfo;

interface

uses Windows, SysUtils, Classes, Registry;

function EnumModems : TStrings;

implementation

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

end.

Author>:
Stas Malinovski
(2:5042/6.6)

Editor>:
Кириллов Арсен Викторович
eg@ipm.lviv.ua
.

Q>:
[API] Как выполнить перезагрузку (reboot) в Windows NT?
A>:
Даже если ты работаешь под Администратором, твоя программка должна
запросить дополнительные привилегии. Вот как это делается (Си):

void Reboot (void)
  {
    HANDLE hToken;
    TOKEN_PRIVILEGES* NewState;
    OSVERSIONINFO OSVersionInfo;

    OSVersionInfo.dwOSVersionInfoSize = sizeof (OSVERSIONINFO);
    GetVersionEx (&OSVersionInfo);
    if (OSVersionInfo.dwPlatformId == VER_PLATFORM_WIN32_NT)
      {
        OpenProcessToken (GetCurrentProcess (), TOKEN_ADJUST_PRIVILEGES,
          &hToken);
        NewState = (TOKEN_PRIVILEGES*) malloc (sizeof
          (TOKEN_PRIVILEGES) + sizeof (LUID_AND_ATTRIBUTES));
        NewState->PrivilegeCount = 1;
        LookupPrivilegeValue (NULL, SE_SHUTDOWN_NAME,
          &NewState->Privileges[0].Luid);
        NewState->Privileges[0].Attributes = SE_PRIVILEGE_ENABLED;
        AdjustTokenPrivileges (hToken, FALSE, NewState, NULL, NULL, NULL);
        free (NewState);
        CloseHandle (hToken);
      }

    ExitWindowsEx (EWX_REBOOT, 0);
  }

Author>:
Andy Nikolayev
an@megatel.ru
(2:5020/56)

Здесь иная редакция этой процедуры (на Паскале, без проверки версии ОС) -

Procedure Shutdown(Name:String;   // Имя машины (\\SERVER)
     Message:String;  // Сообщение
     Delay:Integer;  // Задержка перед рестартом
     Restart,CloseAll:Boolean);
var ph:THandle;
    tp,prevst:TTokenPrivileges;
    rl:DWORD;
begin
OpenProcessToken(GetCurrentProcess,TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,ph);
LookupPrivilegeValue(Nil,'SeShutdownPrivilege',tp.Privileges[0].Luid);
tp.PrivilegeCount:=1;
tp.Privileges[0].Attributes:=2;
AdjustTokenPrivileges(ph,FALSE,tp,SizeOf(prevst),prevst,rl);
InitiateSystemShutdown(PChar(name),PChar(Message),Delay,Restart,CloseAll);
ShowMessage(SysErrorMessage(GetLastError)); // Результат
end;

Editor>:
Sergey Dubovsky
4438645@pager.mirabilis.com
(2:450/103.15)
.

> --- added in v7.1
Q>:
[API] Как узнать язык Windows по умолчанию?
A>:
GetSystemDefaultLCID
GetLocaleInfo

Author>:
Denis G. Priyomov
(2:5030/386.97)
.

Q>:
[API] Как указать системе на необходимость сбросить буфера *.INI-файла на диск?
A>:
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;

Author>:
Sergej Kosinskij
(2:5030/193)
.

Q>:
[OGL] Есть необходимость записать содержимое окна OpenGl, в 'bmp' файл.
Как можно решить эту задачку?
A>:
Вот что попробовал - вроде получилось:

  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;

(gr - объект, в канве которого я рисую с помощью OpenGL)

Author>:
Michael L. Stepuchev
mike@prognoz.ru
.

Q>:
[VCL] Можно ли сделать так - одновременно иметь на экране всегда доступную
форму - например "Навигатор" и  открывая модальные формы, иметь всегда
доступ к форме "Навигатор" ?
A>:
Обманом можно все.

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

И вот это пpивесь на OnShow  почти модальной  фоpмы

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

Author>:
Serge Buzadzhy
(2:467/44.37)
.

> --- added in v7.0
Q>:
[VCL] Хочу реализовать правильный выпадающий контрол (combo). Как это сделать?
A>:
Когда-то потратил немало времени на разбор, как же все таки работаю дропдаун
контролы. В итоге мной был написан маленький юнит, который я положил у себя
в каталоге Demo для ознакомления интерисующихся.
Он маленький (его основная задача -- показать принцип работы, а все остальное
-- как реализуешь), я думаю, что большинству он пригодиться, поэтому публикую
здесь. Касательно твоего вопроса -- реализуй вместо листбокса выпадающий
контрол, который даст тебе функциональность дерева.

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

Author>:
Pasha Schurenko
(2:463/600.1)
.

> --- changed in v7.0
Q>:
Как мне отправить на принтер чистый поток данных?
A>:
Под 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;

Author>:
(Borland/Inprise FAQ N714, переведен Акжаном Абдулиным)

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

=== Cut ===

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.

=== Cut ===

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

Author>:
Oleg Yunets
(2:451/300.24)
.

Q>:
Как создать окна непрямоугольной формы и работать с ними?
A>:
Win32 (Windows'95 or Windows NT 4.0 or above).
Достаточно создать регион нужной формы и вызвать SetWindowRgn -
HRGN rgn := CreateEllipticRgn( 10,10,100,100 );
SetWindowRgn( hMyWnd,rgn );     // Вот и будет круглое окно

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

Author>:
Jouri Mamaev
(2:5080/80.66)
и другие.

Попpобуйте вот этот обpаботчик OnCreate :)
На меня это пpоизвело впечатление.

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

Author>:
Alexander Burnashov
alex@arta.spb.su
(2:5030/254.36)
.

> --- added in v6.1
Q>:
Как убрать публичное свойство компонента/формы из списка видимых/редактируемых
свойств в Инспекторе Обьектов?
A>:
Из TForm property не убиpал, но из TWinControl было дело.
А дело было так :

 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ядом.

Author>:
Andy Svirin
(2:5020/1377.5)
.

Q>:
Как узнать доступные сетевые pесуpсы?
A>:
Вот пример:

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;

Author>:
Alexey Lesovik
(2:5020/898.15)
.

> --- added in v6
Q>:
Как подключать сетевые диски?
A>:
Деpжи pабочий кусок кода из пpогpаммы "мэйлеpа" сетевой FIDO станции:

var nw:TNetResource;

...

nw.dwType:=RESOURCETYPE_DISK;
nw.lpLocalName:=nil;
nw.lpRemoteName:=PChar('\\'+MailServer.RemoteName+'\MAIL');
nw.lpProvider:=nil;
if MailServer.Password<>'' then
   Err:=WNetAddConnection2(nw,PChar(MailServer.Password),nil,0)
                           else
   Err:=WNetAddConnection2(nw,nil,nil,0);
If Err=NO_ERROR then
   begin
   ...
   end;

MailServer.RemoteName и Password -- имя удаленного компа в сети и
паpоль доступа к pесуpсу соответвенно.

ps.: так, как написано, ты будешь к pесуpсу обpащаться как к '\\Comp\Disc'.
    если хочешь подключить сетевой pесуpс как локальный диск -- меняй
    nw.lpLocalName.

pps.: когда(если) закончишь юзать сетевой диск, ставь WNetCancelConnection2.

Author>:
Vadim Saitov
(2:5011/76.13)
.

Q>:
[Win32] Как правильно работать с прозрачными окнами (стиль WS_EX_TRANSPARENT)?
A>:
Стиль окна-формы указывается в CreateParams (если не перепутал).
Только вот когда перемещаешь его, фон остается со старым куском экрана.
Чтобы этого не происходило, то когда pисуешь своё окно, запоминай,
что было под ним,а пpи пеpемещении восстанавливай.

HDC hDC = GetDC(GetDesktopWindow()) тебе поможет..


Author>:
Andrei Bogomolov
http://cardy.hypermart.net
ICQ UIN:7329451
mailto: admin@cardy.hypermart.net
e-pager:7329451@pager.mirabilis.com
(2:5013/11.3)
.

Q>:
[API,W95] Как спрятать окно приложения из списка задач и из таскбара?
A>:
Для NT - всё как обычно, для 95 так:

#define RSP_SIMPLE_SERVICE        0x00000001
#define RSP_UNREGISTER_SERVICE    0x00000000

void SimpleServiceRegister (void)
  {
    HINSTANCE hInstKernel;
    DWORD (__stdcall *pRegisterServiceProcess) (DWORD, DWORD);

    hInstKernel = LoadLibrary ("KERNEL32.DLL");

    if (hInstKernel)
      {
        pRegisterServiceProcess = (DWORD (__stdcall *) (DWORD, DWORD))
GetProcAddress (hInstKernel, "RegisterServiceProcess");

        if (pRegisterServiceProcess)
          {
            pRegisterServiceProcess (NULL, RSP_SIMPLE_SERVICE);
          }

        FreeLibrary (hInstKernel);
      }
  }

Author>:
Andy Nikolayev
an@megatel.ru
(2:5020/56)
.

Q>:
[LNG] Как корректно сравнивать и выполнять арифметические действия с
четырехбайтными беззнаковыми целыми числами (DWORD)?
A>:
Ничего лучшего, чем PChar(a) < PChar(b) пока не пpидумали.

Author>:
Alex Konshin
alexk@msmt.spb.su
(2:5030/217)
.

Q>:
[OGL] Каким обpазом выбиpать pазмеp шpифта, т.к. все мои стpадания по выбоpy
паpаметpов шpифта в CreateFont() никак не отpажались на его pазмеpе :(
Все что я пpидyмал, это юзать glScale(), но в этом слyчае  полyчаем плохое
качество (по сpавнению с той-же Воpдой) пpи малом pазмеpе символов.
A>:
 Вот часть работающего примера на Си (переведенного мною на Паскаль (АА)).

procedure GLSetupRC( pData: Pointer )
//void GLSetupRC(void *pData)
//{
var
//  HDC hDC;
 hDC: HDC;
//  HFONT hFont;
 hFont: HFONT;
//  GLYPHMETRICSFLOAT agmf[128];
 agmf: array [0..127] of GLYPHMETRICSFLOAT;
//  LOGFONT logfont;
 logfont: LOGFONT;

begin
  logfont.lfHeight := -10;
  logfont.lfWidth := 0;
  logfont.lfEscapement := 0;
  logfont.lfOrientation := 0;
  logfont.lfWeight := FW_BOLD;
  logfont.lfItalic := FALSE;
  logfont.lfUnderline := FALSE;
  logfont.lfStrikeOut := FALSE;
  logfont.lfCharSet := ANSI_CHARSET;
  logfont.lfOutPrecision := OUT_DEFAULT_PRECIS;
  logfont.lfClipPrecision := CLIP_DEFAULT_PRECIS;
  logfont.lfQuality := DEFAULT_QUALITY;
  logfont.lfPitchAndFamily := DEFAULT_PITCH;
  //strcpy(logfont.lfFaceName,"Arial");
//  strcpy(logfont.lfFaceName,"Decor");
  StrPCopy( logfont.lfFaceName, 'Decor' );

  glDepthFunc(GL_LESS);
  glEnable(GL_DEPTH_TEST);  // Hidden surface removal
  glFrontFace(GL_CCW);      // Counter clock-wise polygons face out
  glEnable(GL_CULL_FACE);   // Do not calculate insides
  glShadeModel(GL_SMOOTH);  // Smooth shading
  glEnable(GL_AUTO_NORMAL);
  glEnable(GL_NORMALIZE);
  glEnable(GL_COLOR_MATERIAL);

  glClearColor(0.0, 0.0, 0.0, 1.0 );

  glEnable(GL_LIGHTING);
  glLightfv(GL_LIGHT0,GL_AMBIENT,ambientLight);
  glLightfv(GL_LIGHT0,GL_DIFFUSE,diffuseLight);
  glLightfv(GL_LIGHT0,GL_SPECULAR,specular);
  glLightfv(GL_LIGHT0,GL_POSITION,lightPos);
  glEnable(GL_LIGHT0);

  glColorMaterial(GL_FRONT, GL_AMBIENT_AND_DIFFUSE);
  glMaterialfv(GL_FRONT, GL_SPECULAR,specular);
  glMateriali(GL_FRONT,GL_SHININESS,100);

  // Blue 3D Text
  glRGB(0, 0, 255);

  // Select the font into the DC
  hDC := (HDC)pData;
//  hFont = CreateFontIndirect(&logfont);
  hFont := CreateFontIndirect( Addr(logfont) );
  SelectObject (hDC, hFont);

  //create display lists for glyphs 0 through 255 with 0.3 extrusion
  // and default deviation. The display list numbering starts at 1000
  // (it could be any number).
//  if(!wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3,
//                            WGL_FONT_POLYGONS, agmf))
  if not wglUseFontOutlines(hDC, 0, 128, 1000, 0., 0.3,

//>                                         ``` - это тебе поможет
//> Выводить текст можно в любым масштабе

                            WGL_FONT_POLYGONS, agmf) then

     Windows.MessageBox(nil,'Could not create Font Outlines',
                     'Error',MB_OK or MB_ICONSTOP);

  // Delete the font now that we are done
  DeleteObject(hFont);
//}
end;

// void GLRenderScene(void *pData)
procedure GLRenderScene(pData: Pointer);
begin
  (*  ...  *)

  // Draw 3D text
  glListBase(1000);
  glPushMatrix();
  // Set up transformation to draw the string.
  glTranslatef(-35.0, 0.0, -5.0) ;
  glScalef(60.0, 60.0, 60.0);
  glCallLists(3, GL_UNSIGNED_BYTE, 'Decor');
  glPopMatrix();  // Clear the window with current clearing color

  (* ... *)
end;

Author>:
Garik Pozdeev
(2:5021/15.9)
.

Q>:
[API] Как умертвить PC Speaker?
A>:
Это выключит спикеp:
  SyStemParametersInfo(SPI_SETBEEP,0,nil,SPIF_UPDATEINIFILE);

Это включит:
  SyStemParametersInfo(SPI_SETBEEP,1,nil,SPIF_UPDATEINIFILE);

Author>:
Alexey Lesovik
(2:5020/898.15)
.

Q>:
[API,COM] Как создавать ярлыки на рабочем столе?
A>:
  function CreateShortcut(const CmdLine, Args, WorkDir, LinkFile: string):
IPersistFile;
  var
    MyObject  : IUnknown;
    MySLink   : IShellLink;
    MyPFile   : IPersistFile;
    WideFile  : WideString;
  begin
    MyObject := CreateComObject(CLSID_ShellLink);
    MySLink := MyObject as IShellLink;
    MyPFile := MyObject as IPersistFile;
    with MySLink do
    begin
      SetPath(PChar(CmdLine));
      SetArguments(PChar(Args));
      SetWorkingDirectory(PChar(WorkDir));
    end;
    WideFile := LinkFile;
    MyPFile.Save(PWChar(WideFile), False);
    Result := MyPFile;
  end;

  procedure CreateShortcuts;
  var Directory, ExecDir: String;
      MyReg: TRegIniFile;
  begin
    MyReg := TRegIniFile.Create(
      'Software\MicroSoft\Windows\CurrentVersion\Explorer');

    ExecDir := ExtractFilePath(ParamStr(0));
    Directory := MyReg.ReadString('Shell Folders', 'Programs', '') + '\' +
ProgramMenu;
    CreateDir(Directory);
    MyReg.Free;

    CreateShortcut(ExecDir + 'Autorun.exe', '', ExecDir,
      Directory + '\Demonstration.lnk');
    CreateShortcut(ExecDir + 'Readme.txt', '', ExecDir,
      Directory + '\Installation notes.lnk');
    CreateShortcut(ExecDir + 'WinSys\ivi_nt95.exe', '', ExecDir,
      Directory + '\Install Intel Video Interactive.lnk');
  end;

Разберешься?

Author>:
Roman Ryltsov
ryltsov@geocities.com
ryltsov@kharkov.com
http://surf.to/ryltsov

Гм. Вообще правильнее в процедуре CreateShortcuts пользовать
Win32API::GetSpecialFolderLocation с нужным параметром
(CSIDL_PROGRAMS в случае папки "Программы", или CSIDL_DESKTOP в случае
"Рабочего стола").

Editor>:
Akzhan Abdulin
(2:5040/55)
.

Q>:
[API] Как по IP адресу получить HostName (и обратно).
A>:
Хм... А ты увеpен, что пытался найти эту функцию?
Ты, навеpно, будешь очень удивлен (так уж повелось в этой эхе), но это
gethostbyaddr, а если в Winsock2, то можно еще WSAAddressToString
Скачиваешь с microsoft или с intel WinSock2 SDK и документацию (она отдельно),
там все есть.

Мне лень сейчас вспоминать и pазбиpаться, вот тебе кусочек, в котоpом этим
функции используются (не пpетендую на абсолютную истину, но с IP pаботает):

function TGenericNetTask.GetPeerOrigin( const ALogin : String ) : DWORD;
const AddressStrMaxLen = 256;
var len : DWORD;
        ptr : PChar;
        pHE : PHostEnt;
        addr : TSockAddr;
        buf : Array [0..AddressStrMaxLen-1] of Char;
begin
    if FNet=nil then raise ESocketError.Error(-1,ClassName+'.GetPeerAds: Net is
not defined',WSAHOST_NOT_FOUND);
    len := SizeOf(TSockAddr);
    if getpeername(FSocket,addr,len)<>0 then
RaiseLastSocketError(-1,ClassName+'.GetPeerAds: getpeername()');
    case addr.sin_family of
    AF_INET: // TCP/IP
        begin
            pHE := gethostbyaddr( PChar(@addr.sin_addr), SizeOf(TInAddr),
AF_INET );
            if pHE=nil then RaiseLastSocketError(-1,ClassName+'.GetPeerAds:
gethostbyaddr()');
            FPeerNodeName := pHE^.h_name;
            if FNet.NodeByName(FPeerNodeName)=nil then
            begin
                ptr := StrScan(pHE^.h_name,'.');
                if ptr<>nil then FPeerNodeName :=
Copy(pHE^.h_name,1,ptr-pHE^.h_name);
            end;
        end;
    else
        len := AddressStrMaxLen;
        if WSAAddressToStringA(sin,sinlen,nil,buf,len)<>0 then
RaiseLastSocketError(-1,ClassName+'.GetPeerAds: WSAAddressToStringA()');
        ptr := StrRScan(buf,':');
        if ptr<>nil then len := ptr-buf;
        FPeerNodeName := Copy(buf,1,len);
    end;
    Result :=
FNet.EncodeAddress(ALogin,FPeerNodeName,'',[bLoginIdRequired,bNodeIdREquired,bR
aiseError]);
end; {TGenericNetTask.GetPeerOrigin}

Author>:
Alex Konshin
alexk@msmt.spb.su
(2:5030/217)
.

Q>:
[ALG] Есть ли у кого алгоритм переноса русского текста по слогам?

Секция 4 из 8 - Предыдущая - Следующая

Вернуться в раздел "Языки Pascal/Delphi" - Обсудить эту статью на Форуме
Главная - Поиск по сайту - О проекте - Форум - Обратная связь

© faqs.org.ru