faqs.org.ru

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

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

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

A>:
 Вот, когда-то писал для QuarkXPress, который русских переносов не понимает. Не
понимает сложные слова, но в 98% работает нормально.

{***********************************************************
*                                                          *
*           Hypernation for QuarkQPress                    *
*           written by Gorbunov A. A.                      *
*           acdc@media-press.donetsk.ua                    *
*                                                          *
************************************************************}

unit Hyper;

interface

uses
  Windows,Classes,SysUtils;

Function SetHyph(pc:PChar;MaxSize:Integer):PChar;
Function SetHyphString(s : String):String;
Function MayBeHyph(p:PChar;pos:Integer):Boolean;

implementation


Type
  TSymbol=(st_Empty,st_NoDefined,st_Glas,st_Sogl,st_Spec);
  TSymbAR=array [0..1000] of TSymbol;
  PSymbAr=^TSymbAr;

Const
    HypSymb=#$1F;

   Spaces=[' ', ',',';', ':','.','?','!','/', #10, #13 ];

    GlasCHAR=['e', 'L', 'х', '+', 'v', '-','р', '-', 'ю', '+', ' ', '-',
              'ш', 'L', '|', '|', '2', '|',
             { english }
               'e',  'E', 'u',  'U','i',  'I', 'o',  'O', 'a',  'A', 'j',  'J'
];

     SoglChar=['-', 'г' , 'ъ', '|' ,'э', '=' , 'у', '+' , '0', '+' , '', '-' ,
               'ч', '|' , 'i', '-' ,'I', 'L' , 'т', 'T' , 'я', '|' , 'Ё', '|' ,
               'ы', 'T' , 'ф', '-' ,'ц', '|' , '-', '+' , 'ё', 'T' , 'ь', '|' ,
               'E', 'T' , 'с', '+' ,
               { english }
                'q', 'Q','w', 'W', 'r', 'R','t', 'T','y', 'Y','p', 'P','s',
'S',
                'd', 'D','f', 'F', 'g', 'G','h', 'H','k', 'K','l', 'L','z',
'Z',
                'x', 'X','c', 'C', 'v', 'V', 'b', 'B', 'n', 'N','m', 'M' ];

    SpecSign= [ '-', '-','N', '-', 'щ', 'г'];

Function isSogl(c:Char):Boolean;
begin
  Result:=c in SoglChar;
end;

Function isGlas(c:Char):Boolean;
begin
  Result:=c in GlasChar;
end;

Function isSpecSign(c:Char):Boolean;
begin
  Result:=c in SpecSign;
end;

Function GetSymbType(c:Char):TSymbol;
begin
  if isSogl(c) then begin Result:=st_Sogl;exit;end;
  if isGlas(c) then begin Result:=st_Glas;exit;end;
  if isSpecSign(c) then begin Result:=st_Spec;exit;end;
  Result:=st_NoDefined;
end;

Function isSlogMore(c:pSymbAr;start,len:Integer):Boolean;
var i:Integer;
    glFlag:Boolean;
begin
  glFlag:=false;
 for i:=Start to Len-1 do
  begin
   if c^[i]=st_NoDefined then begin Result:=false;exit;end;
   if (c^[i]=st_Glas)and((c^[i+1]<>st_Nodefined)or(i<>Start))
      then
         begin
           Result:=True;
           exit;
         end;
  end;
  Result:=false;
end;

    { ЁрёёEрты ыър яхЁхэюёют }
Function SetHyph(pc:PChar;MaxSize:Integer):PChar;
var
    HypBuff  : Pointer;
    h   : PSymbAr;
    i   : Integer;
    len : Integer;
    Cur : Integer; { Tхъeр  яючш-ш  т ЁрчeыNEшЁe|хь ьрёёштх }
    cw  : Integer; { =юьхЁ сeътv т ёыютх }
    Lock: Integer; { ё-хE-шъ сыюъшЁютюъ }
begin
  Cur:=0;
  len  := StrLen(pc);
  if (MaxSize=0)OR(Len=0) then
                begin
                    Result:=nil;
                    Exit;
                end;

  GetMem(HypBuff,MaxSize);
  GetMem(h,Len+1);
    {  чряюыэхэшх ьрёёштр Eшяют ёшьтюыют  }
  for i:=0 to len-1 do h^[i]:=GetSymbType(pc[i]);
    { ёюсёEтхээю ЁрёёEрэютър яхЁхэюёют }
    cw:=0;
    Lock:=0;
     for i:=0 to Len-1 do
      begin
        PChar(HypBuff)[cur]:=PChar(pc)[i];Inc(Cur);

        if i>=Len-2 then Continue;
        if h^[i]=st_NoDefined then begin cw:=0;Continue;end else Inc(cw);
        if Lock<>0 then begin Dec(Lock);Continue;end;
        if cw<=1 then Continue;
        if not(isSlogMore(h,i+1,len)) then Continue;


        if
(h^[i]=st_Sogl)and(h^[i-1]=st_Glas)and(h^[i+1]=st_Sogl)and(h^[i+2]<>st_Spec)
               then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end;

        if
(h^[i]=st_Glas)and(h^[i-1]=st_Sogl)and(h^[i+1]=st_Sogl)and(h^[i+2]=st_Glas)
               then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end;

        if
(h^[i]=st_Glas)and(h^[i-1]=st_Sogl)and(h^[i+1]=st_Glas)and(h^[i+2]=st_Sogl)
               then begin PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1;end;

        if (h^[i]=st_Spec) then begin
PChar(HypBuff)[cur]:=HypSymb;Inc(Cur);Lock:=1; end;

      end;
    {}
   FreeMem(h,Len+1);
   PChar(HypBuff)[cur]:=#0;
   Result:=HypBuff;
end;

Function Red_GlasMore(p:Pchar;pos:Integer):Boolean;
begin
  While p[pos]<>#0 do
   begin
     if p[pos] in Spaces then begin Result:=False; Exit; end;
     if isGlas(p[pos]) then begin Result:=True; Exit; end;
     Inc(pos);
   end;
  Result:=False;
end;

Function Red_SlogMore(p:Pchar;pos:Integer):Boolean;
Var BeSogl,BeGlas:Boolean;
begin
  BeSogl:=False;
  BeGlas:=False;
  While p[pos]<>#0 do
   begin
     if p[pos] in Spaces then Break;
     if Not BeGlas then BeGlas:=isGlas(p[pos]);
     if Not BeSogl then BeSogl:=isSogl(p[pos]);
     Inc(pos);
   end;
  Result:=BeGlas and BeSogl;
end;

Function MayBeHyph(p:PChar;pos:Integer):Boolean;
var i:Integer;
    len:Integer;
begin
  i:=pos;
  Len:=StrLen(p);
  Result:=
         (Len>3)
         AND
         (i>2)
         AND
         (i<Len-2)
         AND
          (not (p[i] in Spaces))
         AND
          (not (p[i+1] in Spaces))
         AND
          (not (p[i-1] in Spaces))
         AND
         (
         (isSogl(p[i])and isGlas(p[i-1])and isSogl(p[i+1])and
Red_SlogMore(p,i+1))
         OR
((isGlas(p[i]))and(isSogl(p[i-1]))and(isSogl(p[i+1]))and(isGlas(p[i+2])))
         OR
         ((isGlas(p[i]))and(isSogl(p[i-1]))and(isGlas(p[i+1])) and
Red_SlogMore(p,i+1)  )
         OR
         ((isSpecSign(p[i])))
         );

end;

Function SetHyphString(s : String):String;
Var Res:PChar;
begin
  Res:=SetHyph(PChar(S),Length(S)*2)
  Result:=Res;
  FreeMem(Res,Length(S)*2);
end;

end.

Author>:
Alex Gorbunov
acdc@media-press.donetsk.ua
www.media-press.donetsk.ua
(2:465/85.4)
.

> --- changed in v6
Q>:
[Win32] Как получить хэндлы всех пpоцессов, котоpые запущены на данный момент
в системе?
A>:
[W95] под Windows 95 это возможно с использованием вспомогательных
инфоpмационных функций (tool help functions).
Для получения списка пpоцессов надо делать следующее:
1. Cпеpва вызывается фукция
 hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
// - получение снимка состояния системы
2. Process32First() - получене инфоpмации о пеpвом пpоцессе в списке
3. Далее в цикле Process32Next() - получение инфоpмации о следующем
   пpоцессе в списке

Author>:
Dima Bogachev
(2:5020/1056.18)

Пример:

>== Режем pаз ==<

unit KernlUtl;

interface
uses TlHelp32, Windows, Classes, Sysutils;

procedure GetProcessList(List: TStrings);
procedure GetModuleList(List: TStrings);
function GetProcessHandle(ProcessID: DWORD): THandle;
procedure GetParentProcessInfo(var ID: DWORD; var Path: String);

const

  PROCESS_TERMINATE         =  $0001;
  PROCESS_CREATE_THREAD     =  $0002;
  PROCESS_VM_OPERATION      =  $0008;
  PROCESS_VM_READ           =  $0010;
  PROCESS_VM_WRITE          =  $0020;
  PROCESS_DUP_HANDLE        =  $0040;
  PROCESS_CREATE_PROCESS    =  $0080;
  PROCESS_SET_QUOTA         =  $0100;
  PROCESS_SET_INFORMATION   =  $0200;
  PROCESS_QUERY_INFORMATION =  $0400;
  PROCESS_ALL_ACCESS        =
    STANDARD_RIGHTS_REQUIRED or SYNCHRONIZE or $0FFF;


implementation

procedure GetProcessList(List: TStrings);
var
  I: Integer;
  hSnapshoot: THandle;
  pe32: TProcessEntry32;
begin
  List.Clear;
  hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

  if (hSnapshoot = -1) then
      Exit;
  pe32.dwSize := SizeOf(TProcessEntry32);
  if (Process32First(hSnapshoot, pe32)) then
  repeat
    I := List.Add(Format('%x, %x: %s',
      [pe32.th32ProcessID, pe32.th32ParentProcessID, pe32.szExeFile]));
    List.Objects[I] := Pointer(pe32.th32ProcessID);
  until not Process32Next(hSnapshoot, pe32);

  CloseHandle (hSnapshoot);
end;

procedure GetModuleList(List: TStrings);
var
  I: Integer;
  hSnapshoot: THandle;
  me32: TModuleEntry32;
begin
  List.Clear;
  hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, 0);
  if (hSnapshoot = -1) then
      Exit;
  me32.dwSize := SizeOf(TModuleEntry32);
  if (Module32First(hSnapshoot, me32)) then
  repeat
    I := List.Add(me32.szModule);
    List.Objects[I] := Pointer(me32.th32ModuleID);
  until not Module32Next(hSnapshoot, me32);

  CloseHandle (hSnapshoot);
end;

procedure GetParentProcessInfo(var ID: DWORD; var Path: String);
var
  ProcessID: DWORD;
  hSnapshoot: THandle;
  pe32: TProcessEntry32;
begin
  ProcessID := GetCurrentProcessID;
  ID := -1;
  Path := '';

  hSnapshoot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);

  if (hSnapshoot = -1) then
      Exit;

  pe32.dwSize := SizeOf(TProcessEntry32);
  if (Process32First(hSnapshoot, pe32)) then
  repeat
    if pe32.th32ProcessID = ProcessID then
    begin
      ID := pe32.th32ParentProcessID;
      Break;
    end;
  until not Process32Next(hSnapshoot, pe32);

  if ID <> -1 then
  begin
    if (Process32First(hSnapshoot, pe32)) then
    repeat
      if pe32.th32ProcessID = ID then
      begin
        Path := pe32.szExeFile;
        Break;
      end;
    until not Process32Next(hSnapshoot, pe32);
  end;
  CloseHandle (hSnapshoot);
end;

function GetProcessHandle(ProcessID: DWORD): THandle;
begin
  Result := OpenProcess(PROCESS_ALL_ACCESS, True, ProcessID);
end;

end.

>== Режем два ==<

Author>:
Vladimir Gaitanoff
(2:5020/880.5)

[WNT] Под Windows NT:
Исходный текст на языке Си.

#include <windows.h>

#include <stdio.h>

typedef long   (*NtQSI)(LONG, PVOID,LONG, LONG);

struct ThreadInfo
{
        FILETIME ftCreationTime;
        DWORD dwUnknown1;
        DWORD dwStartAddress;
        DWORD dwOwningPID;
        DWORD dwThreadID;
        DWORD dwCurrentPriority;
        DWORD dwBasePriority;
        DWORD dwContextSwitches;
        DWORD dwThreadState;
        DWORD dwUnknown2;
        DWORD dwUnknown3;
        DWORD dwUnknown4;
        DWORD dwUnknown5;
        DWORD dwUnknown6;
        DWORD dwUnknown7;
};

struct ProcessInfo
{
        DWORD dwOffset; // an ofset to the next Process structure
        DWORD dwThreadCount;
        DWORD dwUnkown1[6];
        FILETIME ftCreationTime;
        DWORD dwUnkown2;
        DWORD dwUnkown3;
        DWORD dwUnkown4;
        DWORD dwUnkown5;
        DWORD dwUnkown6;
        WCHAR* pszProcessName;
        DWORD dwBasePriority;
        DWORD dwProcessID;
        DWORD dwParentProcessID;
        DWORD dwHandleCount;
        DWORD dwUnkown7;
        DWORD dwUnkown8;
        DWORD dwVirtualBytesPeak;
        DWORD dwVirtualBytes;
        DWORD dwPageFaults;
        DWORD dwWorkingSetPeak;
        DWORD dwWorkingSet;
        DWORD dwUnkown9;
        DWORD dwPagedPool; // kbytes
        DWORD dwUnkown10;
        DWORD dwNonPagedPool; // kbytes
        DWORD dwPageFileBytesPeak;
        DWORD dwPageFileBytes;
        DWORD dwPrivateBytes;
        DWORD dwUnkown11;
        DWORD dwUnkown12;
        DWORD dwUnkown13;
        DWORD dwUnkown14;
        struct ThreadInfo ati[1];
};


    NtQSI ntqsi;
    HANDLE h;
    int i;
    long j;
    long tt;
    char *vt; // UNICODE

    struct ThreadInfo  *tinfo, *tinf2;
    struct ProcessInfo *pinfo;

    char buf[20480];

void main()
{
    h=LoadLibrary("NTDLL.DLL");
    ntqsi = (NtQSI)GetProcAddress(h,"NtQuerySystemInformation");

    j = (*ntqsi)(5,buf,20480,0);
    pinfo = buf;

    for(;;){
       vt = pinfo->pszProcessName;
       printf("%4lX|%13s|%8ld|%7lX|%7ld",
          pinfo->dwProcessID,vt,
          pinfo->dwThreadCount,pinfo->dwParentProcessID,
          pinfo->dwOffset);
       printf("|%4ld\n",pinfo->dwBasePriority);
       printf("\t|  ID|Owner|State|Priority|Base Priority\n");
       tinfo = &pinfo->ati[0];

       for(i=0;i<pinfo->dwThreadCount;++i){
          tinf2 = &tinfo[i];
          printf("\t|%4lX|%5lX|%5lX|%8s|%8s\n",
             tinf2->dwThreadID,
             tinf2->dwOwningPID,
             tinf2->dwThreadState,
             tinf2->dwCurrentPriority,
             tinf2->dwBasePriority);
       }
       if(pinfo->dwOffset==0) break;
       pinfo = (struct ProcessInfo*)((char *)pinfo + pinfo->dwOffset);
    }
}

Author>:
Viktor Krapivin
(2:450/102.13)
.

> --- added in v5.3
Q>:
[VCL] Как добавить горизонтальную полосу прокрутки в TListBox?
A>:
Компонент VCL TListBox автоматически реализует вертикальную полосу прокрутки.
Полоска прокрутки появляется, когда окно списка слишком мало для показа всех
элементов списка. Однако окно списка не показывает горизонтальной полосы прокрутки,
когда какие-либо элементы списка имеют большую ширину, чем само окно списка.
Конечно, есть возможность добавить горизонтальную полосу прокрутки.
Добавьте следующий код в обработчик события OnCreate Вашей формы:

procedure TForm1.FormCreate(Sender: TObject);
var
  i, MaxWidth: integer;
begin
  MaxWidth := 0;
  for i := 0 to ListBox1.Items.Count - 1 do
    if MaxWidth < ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]) then
      MaxWidth := ListBox1.Canvas.TextWidth(ListBox1.Items.Strings[i]);
    SendMessage(ListBox1.Handle, LB_SETHORIZONTALEXTENT, MaxWidth+2, 0);
end;

Этот код находит ширину, в пикселах, самой длинной строки в окне списка.
Затем он использует сообщение LB_SETHORIZONTALEXTENT для установки горизонтальной
прокручиваемой ширины, в пикселах, для окна списка. Два дополнительных пиксела
добавлены к MaxWidth, чтобы сдвинуть оконечные символы от правой границы окна списка.

Author>:
Delphi Tip, переведен AA.
.

Q>:
Как сконверировать строку из одной кодировки в другую?
A>:
Для перекодирования из текущей кодировки DOS в текущую кодировку Windows
есть функции
Win16: OemToAnsi, AnsiToOem;
Win32: OemToChar, CharToOem.
И они же с суффиксом Buf.

Author>:
AA.

Но если Вы хотите работать с другими кодировками (ISO, 4e) или
получить тот же результат вне зависимости системной локализации,

Примечание: не пытайся копировать таблицу из письма, так как здесь кодировка
KOI8r, а набей ее сам вручную.

type
  TXlatTable = array[0..255] of Char;
  PXlatTable = ^TXlatTable;
const
  Cp866To1251 : TXlatTable = (
   #0,#1,#2,#3,#4,#5,#6,#7,#8,#9,#10,#11,#12,#13,#14,#15,
   #16,#17,#18,#19,#20,#21,#22,#23,#24,#25,#26,#27,#28,#29,#30,#31,
   ' ','!','"','#','$','%','&','''','(',')','*','+',',','-','.','/',
    '0','1','2','3','4','5','6','7','8','9',':',';','<','=','>','?',
   '@','A','B','C','D','E','F','G','H','I','J','K','L','M','N','O',
    'P','Q','R','S','T','U','V','W','X','Y','Z','[','\',']','^','_',
    '`','a','b','c','d','e','f','g','h','i','j','k','l','m','n','o',
    'p','q','r','s','t','u','v','w','x','y','z','{','|','}','~',#127,
   'А','Б','В','Г','Д','Е','Ж','З','И','Й','К','Л','М','H','О','П',
    'Р','С','Т','У','Ф','Х','Ц','Ч','Ш','Щ','Ъ','Ы','Ь','Э','Ю','Я',
    'а','б','в','г','д','е','ж','з','и','й','к','л','м','н','о','п',
    '.','.','.','.','.','.','.','.','.','.','.','.','.','.','.','.',
    '.','.','.','.','.','.','.','.','.','.','.','.','.','.','.','.',
    '.','.','.','.','.','.','.','.','.','.','.','.','.','.','.','.',
    'р','с','т','у','ф','х','ц','ч','ш','щ','ъ','ы','ь','э','ю','я',
  'Ё','ё','?','ё','?','?','?','?','0','-','-',#251,'?','?',#254,#255);

function XlatConvert(const Value:string;
                     const CvtTable:PXlatTable): string;

Implementation

{***********************************
 * Xlat Convering utility          *
 * for Transliterate, Upper, Lower *
 ***********************************}
function XlatConvert(const Value:string;
                     const CvtTable:PXlatTable) : string;
var
  I : Integer;
begin
  if CvtTable = nil then
    Result := Value
  else begin
    Result := '';
    for I := 1 to Length(Value) do begin
      Result := Result + CvtTable^[Byte(Value[I])];
    end;
  end;
end; {XlatConvert}


Author>:
Anatoly Podgoretsky
kvk@estpak.ee
.

> --- added in v5.2
Q>:
Хотелось бы иметь возможность отмены вставки нового узла в TTreeView по
нажатию кнопки Esc. Как сделать?
A>:
unit BetterTreeView;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, CommCtrl;

type
  TTVNewEditCancelEvent = procedure( Sender: TObject;
    Node: TTreeNode; var Delete: Boolean) of object;
  TBetterTreeView = class(TTreeView)
  protected
    FIsEditingNew: Boolean;
    FOnEditCancel: TTVChangedEvent;
    FOnNewEditCancel: TTVNewEditCancelEvent;
    procedure Edit(const Item: TTVItem); override;
  public
    function NewChildAndEdit(Node: TTreeNode; const S: String)
      : TTreeNode;
  published
    property IsEditingNew: Boolean read FIsEditingNew;
    property OnEditCancel: TTVChangedEvent
      read FOnEditCancel write FOnEditCancel;
    property OnNewEditCancel: TTVNewEditCancelEvent
      read FOnNewEditCancel write FOnNewEditCancel;
  end;

implementation

procedure TBetterTreeView.Edit(const Item: TTVItem);
var
  Node: TTreeNode;
  Action: Boolean;
begin
  with Item do begin
    { Get the node }
    if (state and TVIF_PARAM) <> 0 then
      Node := Pointer(lParam)
    else
      Node := Items.GetNode(hItem);

    if pszText = nil then begin
      if FIsEditingNew then begin
        Action := True;
        if Assigned(FOnNewEditCancel) then
          FOnNewEditCancel(Self, Node, Action);
        if Action then
          Node.Destroy
      end
      else
        if Assigned(FOnEditCancel) then
          FOnEditCancel(Self, Node);
    end
    else
      inherited;
  end;
  FIsEditingNew := False;
end;

function TBetterTreeView.NewChildAndEdit
  (Node: TTreeNode; const S: String): TTreeNode;
begin
  SetFocus;
  Result := Items.AddChild(Node, S);
  FIsEditingNew := True;
  Node.Expand(False);
  Result.EditText;
  SetFocus;
end;

end.

Author>:
Том Сван "Секреты..."
.

Q>:
Как вывести на Canvas надпись под углом?
A>:
 Вот, взгляни.

...

function CreateRotatedFont(F : TFont; Angle : Integer) : hFont;
  {-create a rotated font based on the font object F}
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);
...

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

Author>:
Nikita Popov
nix@tekton.dol.ru
(2:5020/87.2)
.

Q>:
Как из программы переключать языки?
A>:
Здесь переключатели на русский и на английский.

procedure SetRU;
var
  Layout: array[0.. KL_NAMELENGTH] of char;
begin
  LoadKeyboardLayout( StrCopy(Layout,'00000419'),KLF_ACTIVATE);
end;

procedure SetEN;
var
  Layout: array[0.. KL_NAMELENGTH] of char;
begin
  LoadKeyboardLayout(StrCopy(Layout,'00000409'),KLF_ACTIVATE);
end;

Author>:
Anton Geleznyak
(2:5000/106)

Можно и так:

 var rus, lat: HKL;

 rus:=LoadKeyboardLayout('00000419', 0);
 lat:=LoadKeyboardLayout('00000409', 0);

 SetActiveKeyboardLayout(rus);

Author>:
Valentin Lavrinenko
(2:463/566.110)
.

Q>:
[Win32] Как удобнее работать с буфером обмена как последовательностью байт?
A>:
Используя потоки -

=== Cut ===
unit ClipStrm;

{
  This unit is Copyright (c) Alexey Mahotkin 1997-1998
  and may be used freely for any purpose. Please mail
  your comments to
  E-Mail: alexm@hsys.msk.ru
  FidoNet: Alexey Mahotkin, 2:5020/433

  This unit was developed during incorporating of TP Lex/Yacc
  into my project. Please visit ftp://ftp.nf.ru/pub/alexm
  or FREQ FILES from 2:5020/433 or mail me to get hacked
  version of TP Lex/Yacc which works under Delphi 2.0+.
}

interface uses Classes, Windows;

type
  TClipboardStream = class(TStream)
  private
    FMemory : pointer;
    FSize : longint;
    FPosition : longint;
    FFormat : word;
  public
    constructor Create(fmt : word);
    destructor Destroy; override;

    function Read(var Buffer; Count : Longint) : Longint; override;
    function Write(const Buffer; Count : Longint) : Longint; override;
    function Seek(Offset : Longint; Origin : Word) : Longint; override;
  end;

implementation uses SysUtils;

constructor TClipboardStream.Create(fmt : word);
var
  tmp : pointer;
  FHandle : THandle;
begin
FFormat := fmt;
OpenClipboard(0);
FHandle := GetClipboardData(FFormat);
FSize := GlobalSize(FHandle);
FMemory := AllocMem(FSize);
tmp := GlobalLock(FHandle);
MoveMemory(FMemory, tmp, FSize);
GlobalUnlock(FHandle);
FPosition := 0;
CloseClipboard;
end;

destructor TClipboardStream.Destroy;
begin
FreeMem(FMemory);
end;

function TClipboardStream.Read(var Buffer; Count : longint) : longint;
begin
if FPosition + Count > FSize then
  Result := FSize - FPosition
else
  Result := Count;
MoveMemory(@Buffer, PChar(FMemory) + FPosition, Result);
Inc(FPosition, Result);
end;

function TClipboardStream.Write(const Buffer; Count : longint) : longint;
var
  FHandle : HGlobal;
  tmp : pointer;
begin
ReallocMem(FMemory, FPosition + Count);
MoveMemory(PChar(FMemory) + FPosition, @Buffer, Count);
FPosition := FPosition + Count;
FSize := FPosition;
FHandle := GlobalAlloc(GMEM_MOVEABLE or GMEM_SHARE or GMEM_ZEROINIT, FSize);
try
  tmp := GlobalLock(FHandle);
  try
    MoveMemory(tmp, FMemory, FSize);
    OpenClipboard(0);
    SetClipboardData(FFormat, FHandle);
  finally
    GlobalUnlock(FHandle);
  end;
  CloseClipboard;
except
  GlobalFree(FHandle);
end;
Result := Count;
end;

function TClipboardStream.Seek(Offset : Longint; Origin : Word) : Longint;
begin
case Origin of
0 : FPosition := Offset;
1 : Inc(FPosition, Offset);
2 : FPosition := FSize + Offset;
end;
Result := FPosition;
end;

end.
=== Cut ===

Author>:
Alexey Mahotkin
alexm@hsys.msk.ru
(2:5020/433)
.

> --- changed in v5.2
Q>:
[D3] Как исправить проблемы с русскими шрифтами *.TTF
в Delphi 3 + Windows NT 4.0 + Service Pack 3.
A>:
    Борланды тут ни при чем - родной Character Map точно так же себя ведет :-(

    Попробуй сделать
[HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion\FontMapper]
DEFAULT=0xcc (204) вместо 0x00 (Именно DEFAULT, а не (Default):-)

Alex Petin
(2:5000/45.10)

HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\FontMapper
DEFAULT=0x000000cc

pекомендую взглянуть на это:

=== Cut ===
REGEDIT4

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows
NT\CurrentVersion\FontSubstitutes ]
"Times"="Times New Roman,204"
"Helvetica"="Arial,204"
"MS Shell Dlg"="MS Sans Serif"
"System,0"="System,204"
"Fixedsys,0"="Fixedsys,204"
"Small Fonts,0"="Small Fonts,204"
"MS Serif,0"="MS Serif,204"
"MS Sans Serif,0"="MS Sans Serif,204"
"Courier,0"="Courier New,204"
"Arial Cyr,0"="Arial,204"
"Courier New Cyr,0"="Courier New,204"
"Times New Roman Cyr,0"="Times New Roman,204"
"Tms Rmn,0"="MS Serif,204"
"Helv,0"="MS Sans Serif,204"
"Arial,0"="Arial,204"
"Courier New,0"="Courier New,204"

=== Cut ===

Суть, я думаю, ясна: для всех используемых Вами UNICODE фонтов явно
пpописываете кодовую стpаницу cp1251.
Это, кстати, поможет заодно и тем, кто жаловался, что Delphi не хочет понимать
Arial Cyr.

Author>:
Alex Konshin
(2:5030/217)
.

Q>:
Можно пpимеp получить, как копиpовать файлы?
A>:
Можно так:

procedure CopyFile(const FileName, DestName: TFileName);
var
  CopyBuffer: Pointer; { buffer for copying }
  TimeStamp, BytesCopied: Longint;
  Source, Dest: Integer; { handles }
  Destination: TFileName; { holder for expanded destination name }
const
  ChunkSize: Longint = 8192; { copy in 8K chunks }
begin
  Destination := ExpandFileName(DestName); { expand the destination path }
  if HasAttr(Destination, faDirectory) then { if destination is a directory...
}
    Destination := Destination + '\' + ExtractFileName(FileName); { ...clone
file name }
  TimeStamp := FileAge(FileName); { get source's time stamp }
  GetMem(CopyBuffer, ChunkSize); { allocate the buffer }
  try
    Source := FileOpen(FileName, fmShareDenyWrite); { open source file }
    if Source < 0 then raise EFOpenError.Create(FmtLoadStr(SFOpenError,
[FileName]));
    try
      Dest := FileCreate(Destination); { create output file; overwrite existing
}
      if Dest < 0 then raise EFCreateError.Create(FmtLoadStr(SFCreateError,
[Destination]));
      try
        repeat
          BytesCopied := FileRead(Source, CopyBuffer^, ChunkSize); { read chunk
}
          if BytesCopied > 0 then { if we read anything... }
            FileWrite(Dest, CopyBuffer^, BytesCopied); { ...write chunk }
        until BytesCopied < ChunkSize; { until we run out of chunks }
      finally
        FileClose(Dest); { close the destination file }

{        SetFileTimeStamp(Destination, TimeStamp);} { clone source's time stamp
}{!!!}
      end;
    finally
      FileClose(Source); { close the source file }
    end;
  finally
    FreeMem(CopyBuffer, ChunkSize); { free the buffer }
Текст: D:\DELPHI\WORK\ID_LIB.PAS        Ст. 0
  end;
FileSetDate(Dest,FileGetDate(Source));
end;

Author>:
Anton Kartamyshev
(2:5020/211.15)

Хм. ИМХО кpутовато будет такие ф-ии писать когда в большинстве
случаев достаточно что-нть типа нижепpиводимого, пpичем оно даже гибче,
так как позволяет скопиpовать как весь файл пpи From и Count = 0,
так и пpоизвольный его кусок.

  function CopyFile( InFile,OutFile: String; From,Count: Longint ): Longint;
  var
    InFS,OutFS: TFileStream;
  begin
    InFS  := TFileStream.Create( InFile,  fmOpenRead );
    OutFS := TFileStream.Create( OutFile, fmCreate   );
    InFS.Seek( From, soFromBeginning );
    Result := OutFS.CopyFrom( InFS, Count );
    InFS.Free;
    OutFS.Free;
  end;

    try..except pасставляются по вкусу, а навоpоты вpоде установки
    атpибутов,даты и вpемени файла и т.п. для ясности удалены, да и не нужны
    они в основном никогда.

Author>:
Dimus Gremyakoff
dimus57@chat.ru, dimus.g@usa.net
(2:5020/768.57)

Конечно, под Win32 имеет смысл использовать функции CopyFile, SHFileOperation.

Author>:
AA.
.

Q>:
Как взять хэндл рабочего стола для манипуляций с иконками рабочего стола?
A>:
Рабочий стол перекрыт сверху компонентом 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 этого ListView,
определенный в модуле CommCtrl, для того, чтобы манипулировать рабочим столом.
Смотрите тему "LVM_xxxx messages" в оперативной справке по Win32.

К примеру, следующая строка кода:

SendMessage( GetDesktopListViewHandle, LVM_ALIGN, LVA_ALIGNLEFT, 0 );

разместит иконки рабочего стола по левой стороне рабочего стола Windows.

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

> --- added in v5.1
Q>:
Как я могу использовать анимированный курсор?
A>:
Сперва Вы должны взять хэндл курсора Windows и присвоить его одному из
элементов массива Cursors обьекта Screen.
Предопределенные курсоры имеют отрицательный индекс, а определенные
пользователем (Вами) курсоры получают положительные индексы.

Ниже пример формы, использующей анимированный курсор:

procedure TForm1.Button1Click(Sender: TObject);
var
  h : THandle;
begin
  h := LoadImage(0,
    'C:\TheWall\Magic.ani',
    IMAGE_CURSOR,
    0,
    0,
    LR_DEFAULTSIZE or
    LR_LOADFROMFILE
  );
  if h = 0 then ShowMessage('Cursor not loaded')
  else
  begin
    Screen.Cursors[1] := h;
    Form1.Cursor := 1;
  end;
end;

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

> --- changed in v5.1
Q>:
Как создать disable'ный битмап из обычного (emboss etc)?
A>:
 CreateMappedBitmap() :-)

Один из паpаметpов yказатель на COLORMAP, в нем для 16 основных цветов делаешь
пеpекодиpовкy, цвета подбеpешь сам из пpинципа:
   все самые яpкие -> в GetSysColor( COLOR_3DLIGHT );
   самые  темные -> GetSysColor( COLOR_3DSHADOW );
   нейтpальные, котpые бyдyт пpозpачные -> GetSysColor( COLOR_3DFACE );

Author>:
Serge Zakharchuk
(2:5060/32)

Так на самом деле вот как делается данная задача:
============
procedure Tform1.aaa(bmpFrom,bmpTo:Tbitmap);
var
  TmpImage,Monobmp:TBitmap;
  IRect:TRect;
begin
  MonoBmp := TBitmap.Create;
  TmpImage:=Tbitmap.Create;
  TmpImage.Width := bmpFrom.Width;
  TmpImage.Height := bmpFrom.Height;
  IRect := Rect(0, 0, bmpFrom.Width, bmpFrom.Height);
  TmpImage.Canvas.Brush.Color := clBtnFace;
  try
    with MonoBmp do
    begin
      Assign(bmpFrom);
      Canvas.Brush.Color := clBlack;
      if Monochrome then
      begin
        Canvas.Font.Color := clWhite;
        Monochrome := False;
        Canvas.Brush.Color := clWhite;
      end;
      Monochrome := True;
    end;
    with TmpImage.Canvas do
    begin
      Brush.Color := clBtnFace;
      FillRect(IRect);
      Brush.Color := clBlack;
      Font.Color := clWhite;
      CopyMode := MergePaint;
      Draw(IRect.Left + 1, IRect.Top + 1, MonoBmp);
      CopyMode := SrcAnd;
      Draw(IRect.Left, IRect.Top, MonoBmp);
      Brush.Color := clBtnShadow;
      Font.Color := clBlack;
      CopyMode := SrcPaint;
      Draw(IRect.Left, IRect.Top, MonoBmp);
      CopyMode := SrcCopy;
      bmpTo.assign(TmpImage);
      TmpImage.free;
    end;
  finally
    MonoBmp.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  aaa(image1.picture.bitmap,image2.picture.bitmap);
  Image2.invalidate;
end;
============
Писал это не я. Это написал сам Борланд (некузявно было бы взглянуть на
класс TButtonGlyph.  Как раз из него я это и выдернул).

Ну а если уже совсем хорошо разобраться, то можно заметить  функцию
ImageList_DrawEx, в которой можно на 25 и 50 процентов уменьшить яркость
(но визуально это очень плохо воспринимается). Соответственно
параметры ILD_BLEND25, ILD_BLEND50, ILD_BLEND-A-MED. Естественно, что
последний абзац работает только с тройкой.

Author>:
Denis Tanayeff
denis@demo.ru

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

Усадьба ру
усадьба ру
novaya-usadba.ru

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

© faqs.org.ru