Секция 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 - Предыдущая - Следующая
© faqs.org.ru
