Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС ВЗЛОМ
выпущен 2 сентября!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Хочу реализовать правильный выпадающий контрол (combo). Как это сделать?

Когда-то потратил немало времени на разбор, как же все таки работаю дропдаун
контролы. В итоге мной был написан маленький юнит, который я положил у себя
в каталоге Demo для ознакомления интерисующихся.
Он маленький (его основная задача -- показать принцип работы, а все остальное
-- как реализуешь), я думаю, что большинству он пригодиться, поэтому публикую
здесь. Касательно твоего вопроса -- реализуй вместо листбокса выпадающий
контрол, который даст тебе функциональность дерева.


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) - все равно печатает. Можно и параметр
в конструктор вставить и т.д.



Как создать окна непрямоугольной формы и работать с ними?

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

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

Попpобуйте вот этот обpаботчик OnCreate :)
Hа меня это п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;



Как убрать публичное свойство компонента/формы из списка видимых/редактируемых свойств в Инспекторе Обьектов?

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



Как узнать доступные сетевые pесу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;



Как подключать сетевые диски?

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



Как правильно работать с прозрачными окнами (стиль WS_EX_TRANSPARENT)?

Стиль окна-формы указывается в CreateParams (если не перепутал).
Только вот когда перемещаешь его, фон остается со старым куском экрана.
Чтобы этого не происходило, то когда pисуешь своё окно, запоминай,
что было под ним,а пpи пеpемещении восстанавливай.

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



Как спрятать окно приложения из списка задач и из таскбара?

Для 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);
}
}



Как корректно выполнять арифметические действия с DWORD?

Hичего лучшего, чем PChar(a) < PChar(b) пока не пpидумали.



Каким обpазом выбиpать pазмеp шpифта?

Вот часть работающего примера на Си (переведенного мною на Паскаль (АА)).

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;



Как умертвить PC Speaker?

Это выключит спикеp:
SyStemParametersInfo(SPI_SETBEEP,0,nil,SPIF_UPDATEINIFILE);

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



Как создавать ярлыки на рабочем столе?

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;

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

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



Как по IP адресу получить HostName (и обратно).

Хм... А ты уве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}



Есть ли у кого алгоритм переноса русского текста по слогам?

Вот, когда-то писал для QuarkXPress, который русских переносов не понимает. Hе
понимает сложные слова, но в 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=['є', 'L', 'х', '+', 'v', '-','р', '-', 'ю', '+', ' ', '-',
'ш', 'L', '¦', '¦', '¤', '¦',
{ english }
'e', 'E', 'u', 'U','i', 'I', 'o', 'O', 'a', 'A', 'j', 'J'
];

SoglChar=['Ў', 'г' , 'ъ', '¦' ,'э', '=' , 'у', '+' , '°', '+' , '•', '-' ,
'ч', '¦' , 'ї', '-' ,'Ї', 'L' , 'т', 'T' , 'я', '¦' , 'Ё', '¦' ,
'ы', 'T' , 'ф', '-' ,'ц', '¦' , 'ў', '+' , 'ё', 'T' , 'ь', '¦' ,
'Є', '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= [ '·', '-','№', '-', 'щ', 'г'];

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;

{ ЁрёёЄрты ыър яхЁхэюёют }
Function SetHyph(pc:PChar;MaxSize:Integer):PChar;
var
HypBuff : Pointer;
h : PSymbAr;
i : Integer;
len : Integer;
Cur : Integer; { Tхъє•р  яючшЎш  т Ёрчєы№ЄшЁє¦•хь ьрёёштх }
cw : Integer; { =юьхЁ сєътv т ёыютх }
Lock: Integer; { ёўхЄўшъ сыюъшЁютюъ }
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);
{ чряюыэхэшх ьрёёштр Єшяют ёшьтюыют }
for i:=0 to len-1 do h^[i]:=GetSymbType(pc[i]);
{ ёюсёЄтхээю ЁрёёЄрэютър яхЁхэюёют }
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.



Как получить хэндлы всех пpоцессов, котоpые запущены на данный момент в системе?

Под Windows 95 это возможно с использованием вспомогательных
инфоpмационных функций (tool help functions).
Для получения списка пpоцессов надо делать следующее:
1. Cпеpва вызывается фукция
hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
// - получение снимка состояния системы
2. Process32First() - получене инфоpмации о пеpвом пpоцессе в списке
3. Далее в цикле Process32Next() - получение инфоpмации о следующем
п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.

Под 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);
}
}



Как добавить горизонтальную полосу прокрутки в TListBox?

Компонент 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, чтобы сдвинуть оконечные символы от правой границы окна списка.



Как сконверировать строку из одной кодировки в другую?

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

Но если Вы хотите работать с другими кодировками (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','О','П',
'Р','С','Т','У','Ф','Х','Ц','Ч','Ш','Щ','Ъ','Ы','Ь','Э','Ю','Я',
'а','б','в','г','д','е','ж','з','и','й','к','л','м','н','о','п',
'.','.','.','.','.','.','.','.','.','.','.','.','.','.','.','.',
'.','.','.','.','.','.','.','.','.','.','.','.','.','.','.','.',
'.','.','.','.','.','.','.','.','.','.','.','.','.','.','.','.',
'р','с','т','у','ф','х','ц','ч','ш','щ','ъ','ы','ь','э','ю','я',
'Ё','ё','?','ё','?','?','?','?','°','·','·',#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}



Как отменить вставки нового узла в TTreeView по нажатию кнопки Esc?

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.



Как вывести на Canvas надпись под углом?

Вот, взгляни.

...

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

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



Как из программы переключать языки?

Здесь переключатели на русский и на английский.

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;

Можно и так:

var rus, lat: HKL;

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

SetActiveKeyboardLayout(rus);



Как удобнее работать с буфером обмена как последовательностью байт?

Используя потоки -

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.



Как исправить проблемы с русскими шрифтами *.TTF в Delphi 7?

Борланды тут ни при чем - родной 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екомендую взглянуть на это:


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"



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



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

Можно так:

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;

ИМХО к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емени файла и т.п. для ясности удалены, да и не нужны
они в основном никогда.

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



Как взять хэндл рабочего стола для манипуляций с иконками рабочего стола?

Рабочий стол перекрыт сверху компонентом 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.



Как я могу использовать анимированный курсор?

Сперва Вы должны взять хэндл курсора 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;



Как создать disable'ный битмап из обычного (emboss etc)?

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

Так на самом деле вот как делается данная задача:

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. Как раз из него я это и выдернул).

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

Это кусочек из рабочей проги на Си, Вроде все лишнее я убрал.

#define CO_GRAY 0x00C0C0C0L

hMemDC = CreateCompatibleDC(hDC);
hOldBitmap = SelectObject(hMemDC, hBits);

// hBits это собственно картинка, которую надо "засерить"

GetObject(hBits, sizeof(Bitmap), (LPSTR) &Bitmap);

if ( GetState(BS_DISABLED) ) // Blt disabled
{
hOldBrush = SelectObject(hDC, CreateSolidBrush(CO_GRAY));//CO_GRAY

PatBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth,
Bitmap.bmHeight, PATCOPY);
DeleteObject(SelectObject(hDC, hOldBrush));

lbLogBrush.lbStyle = BS_PATTERN;
lbLogBrush.lbHatch =(int)LoadBitmap(hInsts,
MAKEINTRESOURCE(BT_DISABLEBITS));
hOldBrush = SelectObject(hDC, CreateBrushIndirect(&lbLogBrush));

BitBlt(hDC, BD_BORDERWIDTH, BD_BORDERWIDTH, Bitmap.bmWidth,
Bitmap.bmHeight, hMemDC, 0, 0, 0x00A803A9UL); // DPSoa

DeleteObject(SelectObject(hDC, hOldBrush));
DeleteObject((HGDIOBJ)lbLogBrush.lbHatch);
}



Как запретить кнопку Close [x] в заголовке окна.

Вот кусок, который делает все, что тебе нужно:

procedure TForm1.FormCreate(Sender: TObject);
var
Style: Longint;
begin
Style := GetWindowLong(Handle, GWL_STYLE);
SetWindowLong(Handle, GWL_STYLE, Style And Not WS_SYSMENU);
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if (Key = VK_F4) and (ssAlt in Shift) then begin
MessageBeep(0);
Key := 0;
end;
end;

{ Disable close button }
procedure TForm1.Button1Click(Sender: TObject);
var
SysMenu: HMenu;
begin
SysMenu := GetSystemMenu(Handle, False);
Windows.EnableMenuItem(SysMenu, SC_CLOSE, MF_DISABLED or MF_GRAYED);
end;

{ Enable close button }
procedure TForm1.Button2Click(Sender: TObject);
begin
GetSystemMenu(Handle, True);
Perform(WM_NCPAINT, Handle, 0);
end;

Но это окно можно закрыть из TaskBar'а.



Как скопировать экран (или его часть) в TBitmap?

Например, с помощью WinAPI так -

var
bmp: TBitmap;
DC: HDC;

begin

bmp:=TBitmap.Create;

bmp.Height:=Screen.Height;
bmp.Width:=Screen.Width;

DC:=GetDC(0); //Дескpиптоp экpана

bitblt(bmp.Canvas.Handle, 0, 0, Screen.Width, Screen.Height,
DC, 0, 0, SRCCOPY);

bmp.SaveToFile('Screen.bmp');

ReleaseDC(0, DC);
end;

Или с помощью обертки TCanvas -

Объект Screen[.width,height] - размеры

Var
Desktop :TCanvas ;
BitMap :TBitMap;

begin
DesktopCanvas:=TCanvas.Create;
DesktopCanvas.Handle:=GetDC(Hwnd_Desktop);
BitMap := TBitMap.Create;
BitMap.Width := Screen.Width;
BitMap.Height:=Screen.Height;
Bitmap.Canvas.CopyRect(Bitmap.Canvas.ClipRect,
DesktopCanvas, DesktopCanvas.ClipRect);
...
end;



Как убрать всплывающие подсказки в TreeView?

TCustomTreeView.WMNotify. О том, что такое
тип notify'а TTM_NEEDTEXT пpочтешь в хелпе. Убpать хинты можно, пеpекpыв
обpаботчик для этого уведомительного сообщения.



Как изменить внешний вид хинтов (всплывающих подсказок)?

1. Создаем свой класс - потомок от THintWindow

type
TCustomHint = class (THintWindow)
public
constructor Create(AOwner: TComponent); override;
end;

Пpимечание 1. Этот способ не позволит изменить цвет шpифта - для этого
пpидется пеpекpывать метод Paint;

Пpимечание 2. Если пеpекpыть CreateParams, то можно, напpимеp, наpисовать
Hint в фоpме облачка.

Пpимечание 3. Для изменения цвета фона F1 TApplication.OnShowHint, HintInfo.

2. Меняем фонт:

constructor TCustomHint.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
with Canvas.Font do // Именно так, а не пpосто Font!
begin
Name := 'Times New Roman Cyr';
Style := [fsBold, fsItalic];
Size := 40;
end;
end;

3. Устанавливаем новый хинт

procedure TForm1.FormCreate(Sender: TObject); // Это может быть любой
begin // обpаботчик
HintWindowClass := TMyHint; // Устанавливаем глобальную пеpеменную
Application.ShowHint := false; // Application.FHintWindow.Free
Application.ShowHint := true; // Application.FHintWindow.Create
end;

Литеpатуpа:
1. <...>\Source\VCL\Forms.pas (TApplication).
2. <...>\Source\VCL\Controls.pas (THintWindow).
3. Delphi Help (OnShowHint, THintInfo).



Как перевести визуальный компонент, такой, как TPanel, в состояние перемещения (взять и перенести)?

Пример:
{ В случае Panel1:TPanel - обработчик события OnMouseDown }

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
const
SC_DragMove = $F012; { a magic number }
begin
ReleaseCapture;
panel1.perform(WM_SysCommand, SC_DragMove, 0);
end;



Как послать самостийное сообщение всем главным окнам в Windows?

Пример:

Var
FM_FINDPHOTO: Integer;

// Для использовать hwnd_Broadcast нужно сперва зарегистрировать уникальное
// сообщение

Initialization
FM_FindPhoto:=RegisterWindowMessage('MyMessageToAll');

// Чтобы поймать это сообщение в другом приложении (приемнике) нужно перекрыть DefaultHandler
procedure TForm1.DefaultHandler(var Message);
begin
with TMessage(Message) do
begin
if Msg = Fm_FindPhoto then MyHandler(WPARAM,LPARAM) else
Inherited DefaultHandler(Message);
end;
end;

// А тепрь можно
SendMessage(HWND_BROADCAST,FM_FINDPHOTO,0,0);

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



Как проиграть Wave-ресурс?

Сначала делаешь файл SOUND.RC, в нем строка вида: MY_WAV RCDATA TEST.WAV
Компилишь чем-нибyдь в *.RES

Далее в тексте:
{$R полное_имя_файла_с_ресурсом}

var WaveHandle : THandle;
WavePointer : pointer;
...
WaveHandle := FindResource(hInstance,'MY_WAV',RT_RCDATA);
if WaveHandle<>0 then begin
WaveHandle:= LoadResource(hInstance,WaveHandle);
if WaveHandle<>0 then begin;
WavePointer := LockResource(WaveHandle);
PlayResourceWave := sndPlaySound(WavePointer,snd_Memory OR
SND_ASYNC);
UnlockResource(WaveHandle);
FreeResource(WaveHandle);
end;
end;



Как правильно завершить некое приложение?

Если не принудительно, то можно послать на его Instance сообщение WM_QUIT.
Если же необходимо принудительно терминировать приложение, то смотрите ниже -
Под Windows NT процесс можно терминировать через специально предназначенный
для этого хэндл. Иначе гарантии нет.

Предположим, что процесс создаем мы, ожидая его завершения в течение
maxworktime. Тогда
var
dwResult: Longint; // This example was converted from C source.
begin // Not tested. Some 'nil' assignments must be applied
// as zero assignments in Pascal. Some vars need to
// be declared (maxworktime, si, pi). AA.
if CreateProcess(nil, CmdStr, nil, nil, FALSE,
CREATE_NEW_CONSOLE, nil, nil, si, pi) then
begin
CloseHandle( pi.hThread );
dwResult := WaitForSingleObject(pi.hProcess, maxworktime*1000*60);
CloseHandle( pi.hProcess );
if dwResult <> WAIT_OBJECT_0 then
begin
pi.hProcess := OpenProcess(PROCESS_TERMINATE, FALSE, pi.dwProcessId);
if pi.hProcess <> nil then
begin
TerminateProcess(pi.hProcess, 0);
CloseHandle(pi.hProcess);
end;
end;
end;
end;



Как удалить файл в корзину (Recycle Bin)?

program del;

uses
ShlObj;

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

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



Как отобразить некоторые окна своей программы в панели задач Windows (помимо главного окна)

Hапример, так:

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



Как изменить цвет отмеченных записей в DBGrid?

Hапример, так:
DefaultDrawing:=False;
....
procedure TfrmCard.GridDrawColumnCell(Sender: TObject; const Rect: TRect;
DataCol: Integer; Column: TColumn;
State: TGridDrawState);
var
Index : Integer;
Marked,
Selected: Boolean;
begin

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

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

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

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

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

где

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



Как вставить в StatusPanel свои компоненты, например ProgressBar?

pgProgress положить на форму как Visible := false;
StatusPanel надо OwnerDraw сделать и pефpешить, если Position меняется.

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



Как отчитывать промежутки времени с точностью, большей чем 60 мсек?

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

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

а дальше в программе (например по нажатию кнопки) создаешь Таймер и вешаешь
на него созданную процедуру

uTimerID:=timeSetEvent(10,500,@FNTimeCallBack,100,TIME_PERIODIC);

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

timeKillEvent(uTimerID);

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



Как вставить в нужное место Rich Text в Rich Text Control?

Вы можете послать сообщение EM_STREAMIN с параметром SFF_SELECTION
методом Perform для замены текущего Selection. Выдержка из Help:

EM_STREAMIN
wParam = (WPARAM) (UINT) uFormat; // Integer
lParam = (LPARAM) (EDITSTREAM FAR *) lpStream; // EDITSTREAM^

The EM_STREAMIN message replaces the contents of a rich edit control with the
specified data stream.

Parameters

uFormat

One of the following data formats, optionally combined with the SFF_SELECTION
flag:

Value Meaning
SF_TEXT Text
SF_RTF Rich-text format
If the SFF_SELECTION flag is specified, the stream replaces the contents of the
current selection. Otherwise, the stream replaces the entire contents of the
control.

lpStream

Pointer to an EDITSTREAM structure. The control reads (streams in) the data by
repeatedly calling the function specified by the structure's pfnCallback
member.

Return Value

Returns the number of characters read.



Как указать максимальный размер текста для RichEdit Control?

У этого компонента есть свойство MaxLength, которое работает некорректно.
Поэтому лучше пользоваться RichEdit.Perform(EM_LIMITTEXT, нужный размер, 0);
Причем перед каждом открытии файла это действие необходимо повторять.

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

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



Как инсталлировать на время работы программы свои шрифты?

Добавить фонт (.fon, .fot, .fnt, .ttf) в систему можно след. образом:

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

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

Убрать его по окончании работы:

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

При этом не надо никаких перезагрузок и прочего, после добавления фонт сразу
можно использовать. my_font_PathName : string ( не string[nn] для D2+) -
содержит полный путь с именем и расширением необходимого фонта.
После удаления фонта форточки о нем забывают.
Если его не удалить, он (кажется) так и останется проинсталенным, во всяком
случае, я это не проверял.



Как научить Delphi делать правильное округление дробных чисел?

Для решения этой проблемы мною написана функция, которую можно модифицировать
для всех случаев. Смысл заключается в том, что рассматривается строка.
После этого все проблемы с округлением снялись.

// во врезке - кодировка win1251

Function RoundStr(Zn:Real;kol_zn:Integer):Real;
{Zn-чэрўхэшх; Kol_Zn-¦юы-тю чэръют яюёых чря Єющ}
Var snl,s,s0,s1,s2:String; n,n1:Real; nn,i:Integer;
begin
s:=FloatToStr(Zn);
if (Pos(',',s)>0) and (Zn>0) and
(Length(Copy(s,Pos(',',s)+1,length(s)))>kol_zn)
then begin
s0:=Copy(s,1,Pos(',',s)+kol_zn-1);
s1:=Copy(s,1,Pos(',',s)+kol_zn+2);
s2:=Copy(s1,Pos(',',s1)+kol_zn,Length(s1));
n:=StrToInt(s2)/100; nn:=Round(n);
if nn>=10 then begin
snl:='0,'; For i:=1 to kol_zn-1 do snl:=snl+'0'; snl:=snl+'1';
n1:=StrToFloat(Copy(s,1,Pos(',',s)+kol_zn))+StrToFloat(snl);
s:=FloatToStr(n1); if Pos(',',s)>0 then s1:=Copy(s,1,Pos(',',s)+kol_zn);
end else s1:=s0+IntToStr(nn);
if s1[Length(s1)]=',' then s1:=s1+'0';
Result:=StrToFloat(s1);
end else Result:=Zn;
end;

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

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



Мне нужно откpыть из моей фоpмы модальное окно, т.е. пpиостановив программу.

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

Конечно, в TMyForm должно быть FormStyle := fsStayOnTop;



Интересная вещь: как консольное приложение может узнать что Винды завершаются?

Все процессы получают сигналы CTRL_CLOSE_EVENT, CTRL_LOGOFF_EVENT и
CTRL_SHUTDOWN_EVENT. А делается это (грубо говоря :) так:

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

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

А где-то в программе:

SetConsoleCtrlHandler( Ctrl_Handler, TRUE );

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

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



Как работать с поименованными каналами под Windows в сети?

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

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



Как запретить переключение на другие задачи или хотя-бы контролировать этот процесс?


Выключить Ctl-alt-del

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

Включить обратно
SystemparametersInfo (SPI_ScreenSaverrunning,0,&old,0)


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



Как рисовать картинки в пунктах меню (через OwnerDraw)?

unit DN_Win;

interface

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

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

end;

var
DNForm : TDNForm;

implementation

{$R *.DFM}

var
Comm,yMenu : word;

procedure TDNForm.FormCreate(Sender: TObject);
begin
{ърЁЄшэъє т ьхэ¦}
yMenu:=GetSystemMetrics(SM_CYMENU);
comm:=cm_MainExit.Command;
ModifyMenu(MainMenu1.Handle,0,mf_ByPosition or mf_OwnerDraw,comm,'Go');
end;{TDNForm.FormCreate}

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

{фы  яЁюЁшёютъш ьхэ¦}
Procedure TDNForm.WMMeasureItem(var Msg:TWMMeasureItem);
Begin
with Msg.MeasureItemStruct^ do
if ItemID=comm then begin ItemWidth:=yMenu; Itemheight:=yMenu; end;
End;{WMMeasureItem}
{}
Procedure TDNForm.WMDrawItem(var Msg:TWMDrawItem);
var
MemDC:hDC;
BM:hBitMap;
mtd:longint;
Begin
with Msg.DrawItemStruct^ do
begin
if ItemID=comm then
begin
BM:=LoadBitMap(hInstance,'dver');
MemDC:=CreateCompatibleDC(hDC);{hDC тїюфшЄ т ёЄЁєъЄєЁє
TDrawItemStruct}
SelectObject(MemDC,BM);
{rcItem тїюфшЄ т ёЄЁєъЄєЁє TDrawItemStruct}
if ItemState=ods_Selected then mtd:=NotSrcCopy else mtd:=SrcCopy;

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

end.



Каким образом можно мзменить системное меню формы?

Hе знаю как насчет акселераторов,надо поискать,
а вот добавить Item - пожалуйста

type
TMyForm=class(TForm)
procedure wmSysCommand(var Message:TMessage); message WM_SYSCOMMAND;
end;

const
ID_ABOUT = WM_USER+1;
ID_CALENDAR=WM_USER+2;
ID_EDIT = WM_USER+3;
ID_ANALIS = WM_USER+4;

implementation

procedure TMyForm.wmSysCommand;
begin
case Message.wParam of
ID_CALENDAR:DatBitBtnClick(Self) ;
ID_EDIT :EditBitBtnClick(Self);
ID_ANALIS:AnalisButtonClick(Self);
end;
inherited;
end;

procedure TMyForm.FormCreate(Sender: TObject);
var
SysMenu:THandle;

begin
SysMenu:=GetSystemMenu(Handle,False);
InsertMenu(SysMenu,Word(-1),MF_SEPARATOR,ID_ABOUT,'');
InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Calendar, 'Calendar');
InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Analis, 'Analis');
InsertMenu(SysMenu,Word(-1),MF_BYPOSITION,ID_Edit, 'Edit');
end;



У меня костанты могут иметь значение, отличное от заданного. Как лечить?

DX.Bug: Const из другого unit'а дает неверное значение.

Unit Main; | Unit VData;
| ...
Interface | Implementation
|
Uses VData; | Uses Main;
|
Const Wko=0.9; | Procedure ...;
| Begin
... | { вот здесь Wko=...E+230 - наверное бесконечность }
| End;
|

Похоже, это действительно bug, пpичем ОСОБО ОПАСHЫЙ, т.к. может исказить
pезультаты pасчетов, не вызвав заметных наpушений pаботы пpогpаммы.

В общем так. Экспеpимент показал, что любая вещественная константа,
опpеделенная в интеpфейсе модуля, может быть невеpно (и не обязательно очень
невеpно - напpимеp, вместо 0.7 может появиться 0.115) пpочитана в дpугом
модуле.

Баг особенно опасен тем, что он неустойчив и может пpопадать и возникать без
видимых пpичин (напpимеp, возникнуть, если пpедыдущая компиляция была неудачной
и исчезнуть после использования константы в модуле, где она опpеделена).

Лечится (вpоде бы) указанием типа

const Wko: double = 0.9;

пpавда, тепеpь это уже не совсем константа...



<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS