Секция 6 из 8 - Предыдущая - Следующая
Все секции
- 1
- 2
- 3
- 4
- 5
- 6
- 7
- 8
Это кусочек из рабочей проги на Си, Вроде все лишнее я убрал.
====================
#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);
}
==================
Author>:
Andy Nikishin
http://www.gs.ru/~links/andy.shtml
(2:5031/16.2)
.
Q>:
Как запретить кнопку Close [x] в заголовке окна.
A>:
Вот кусок, который делает все, что тебе нужно:
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;
Author>:
Alexander Petrushev
(2:5001/88.10)
=== Cut ===
{ 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;
=== Cut ===
Но это окно можно закрыть из TaskBar'а.
Author>:
Vlad Filyakov
(2:5022/26.9)
.
> --- added in v5
Q>:
Как скопировать экран (или его часть) в TBitmap?
A>:
Например, с помощью 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;
Author>:
Peter Maishev
(2:5020/1530.31)
Или с помощью обертки 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;
Author>:
Serg Lukashov
serg@tnd.belpak.gomel.by, serg.d.lukashov@usa.net
(2:452/9.16)
.
Q>:
[Win32] Как убрать всплывающие подсказки в TreeView?
A>:
TCustomTreeView.WMNotify. О том, что такое
тип notify'а TTM_NEEDTEXT пpочтешь в хелпе. Убpать хинты можно, пеpекpыв
обpаботчик для этого уведомительного сообщения.
Author>:
Eugene Mayevski
Eugene-Mayevski@usa.net
(2:463/209.209)
.
Q>:
Как изменить внешний вид хинтов (всплывающих подсказок)?
A>:
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).
Author>:
Dmitry Medved
(2:464/58.7)
.
Q>:
Как перевести визуальный компонент, такой, как TPanel, в состояние перемещения
(взять и перенести)?
A>:
Пример:
{ В случае 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;
Author>:
Borland TI N2909
(перевод: Акжан Абдулин)
.
Q>:
Как послать самостийное сообщение всем главным окнам в Windows?
A>:
Пример:
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.
Author>:
Andrey Burov
(2:463/238.19)
.
Q>:
Как проиграть Wave-ресурс?
A>:
Сначала делаешь файл 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;
Author>:
Serg Vostrikov
(2:5053/15.3)
.
Q>:
Как правильно завершить некое приложение?
A>:
Если не принудительно, то можно послать на его 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;
Author>:
Serge Nozhenko
(2:5020/175)
.
Q>:
[Win32] Как удалить файл в корзину (Recycle Bin)?
A>:
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.
Author>:
Ed Lagerburg
lagerbrg@euronet.nl
.
Q>:
Как отобразить некоторые окна своей программы в панели задач Windows
(помимо главного окна)
A>:
Например, так:
procedure TMyForm.CreateParams(var Params :TCreateParams); {override;}
begin
inherited CreateParams(Params); {CreateWindowEx}
Params.ExStyle := Params.ExStyle or WS_Ex_AppWindow;
end;
Author>:
Max Rusov
(2:5030/456.1)
.
Q>:
Как изменить цвет отмеченных записей в DBGrid?
A>:
Например, так:
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;
Author>:
Vadim Puzanov
vadim@mimex.krasnoyarsk.su
(2:5090/20)
.
Q>:
Как вставить в StatusPanel свои компоненты, например ProgressBar?
A>:
pgProgress положить на форму как Visible := false;
StatusPanel надо OwnerDraw сделать и pефpешить, если Position меняется.
>== Режем pаз ==<
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;
>== Режем два ==<
Author>:
Vladimir Gaitanoff
vg@divo.ru
(2:50/430.2)
.
Q>:
Как отчитывать промежутки времени с точностью, большей чем 60 мсек?
A>:
Для начала описываешь процедуру, которая будет вызываться по сообщению от
таймера :
procedure FNTimeCallBack(uTimerID, uMessage: UINT;dwUser, dw1, dw2: DWORD)
stdcall;
begin
//
// Тело процедуры.
end;
а дальше в программе (например по нажатию кнопки) создаешь Таймер и вешаешь
на него созданную процедуру
uTimerID:=timeSetEvent(10,500,@FNTimeCallBack,100,TIME_PERIODIC);
Подробности смотри в Help.
Ну и в конце убиваешь таймер
timeKillEvent(uTimerID);
И все. Точность этого способа до 1 мсек. минимальный интервал времени можно задавать 1 мсек.
Author>:
Leonid Tserling
tlv@f3334.dd.vaz.tlt.ru
.
Q>:
Как вставить в нужное место Rich Text в Rich Text Control?
A>:
Вы можете послать сообщение 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.
Author>:
Mikhail Chernyshev
Mikhail-Chernyshev@usa.net
(2:4615/26)
.
Q>:
Как указать максимальный размер текста для RichEdit Control?
A>:
У этого компонента есть свойство MaxLength, которое работает некорректно.
Поэтому лучше пользоваться RichEdit.Perform(EM_LIMITTEXT, нужный размер, 0);
Причем перед каждом открытии файла это действие необходимо повторять.
Author>:
Maxim Liverovskiy
(2:5030/254.38)
Если Вы передаете в качестве размера 0, то ОС ограничивает размер
OS Specific Default Value. Реально, по результатам моих экспериментов,
поставить можно размер, чуть меньший доступной виртуальной памяти.
Я ограничился 90% от свободной виртуалки.
Для того, чтобы не повторять этот вызов (EM_LIMITTEXT), можно воспользоваться
сообщением EM_EXLIMITTEXT.
Author>:
Stas Mehanoshin
(2:5030/143.23)
.
Q>:
Как инсталлировать на время работы программы свои шрифты?
A>:
Добавить фонт (.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+) -
содержит полный путь с именем и расширением необходимого фонта.
После удаления фонта форточки о нем забывают.
Если его не удалить, он (кажется) так и останется проинсталенным, во всяком
случае, я это не проверял.
Author>:
Andry Trushin
(2:5020/474.7)
.
> --- changed in v5
Q>:
Как научить Delphi делать правильное округление дробных чисел?
A>:
Для решения этой проблемы мною написана функция, которую можно модифицировать
для всех случаев. Смысл заключается в том, что рассматривается строка.
После этого все проблемы с округлением снялись.
// во врезке - кодировка win1251
=== Cut ===
Function RoundStr(Zn:Real;kol_zn:Integer):Real;
{Zn-чэр-хэшх; Kol_Zn-|юы-тю чэръют яюёых чря Eющ}
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;
=== Cut ===
Author>:
Nadya Kutareva
(2:5021/13.11)
Все-таки работа со строками здесь излишество -
=== Cut ===
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;
=== Cut ===
Author>:
Ilya Golovko
(2:5010/101.19)
.
> --- added in v4.1
Q>:
Мне нужно откpыть из моей фоpмы модальное окно, т.е. пpиостановить
pаботу в моей фоpме до обpаботки этого модального окна.
Но пpи этом я теpяю возможность убpать (минимизиpовать) мою фоpму.
A>:
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;
Author>:
Eugeny D.Shtefanov
shtefanov@usa.net
.
Q>:
Интересная вещь: как консольное приложение может узнать что Винды
завершаются?
A>:
Все процессы получают сигналы 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 -- там всё есть.
Author>:
Alexander V. Naumochkin
(2:5020/59)
.
Q>:
Как работать с поименованными каналами под W'95/NT в сети?
A>:
сервер :
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 ...
Author>:
Jack Sinelnikov
(2:5054/9.13)
.
Q>:
Как запретить переключение на другие задачи или хотя-бы контролировать
этот процесс?
A>:
=== Cut ===
Выключить Ctl-alt-del
bool old;
SystemParametersInfo (SPI_SCREENSAVERRUNNING,1,&old,0)
Включить обратно
SystemparametersInfo (SPI_ScreenSaverrunning,0,&old,0)
=== Cut ===
Мне помогло. Хоть и пpишлось повозиться: в хэлпе нет пpо паpаметp
SPI_SCREENSAVERRUNNING...
Author>:
Konstantin Okolelyh
(2:5025/77.23)
.
Q>:
Как рисовать картинки в пунктах меню (через OwnerDraw)?
A>:
>================ ====================
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
{ърЁEшэъe т ьхэ|}
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 тiюфшE т ёEЁeъEeЁe
TDrawItemStruct}
SelectObject(MemDC,BM);
{rcItem тiюфшE т ёEЁeъEeЁe 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.
>================ ====================
Author>:
Eugeny Sverchkov
es906@kolnpp.elektra.ru
(2:5031/12.23)
.
Q>:
Каким образом можно мзменить системное меню формы?
A>:
Не знаю как насчет акселераторов,надо поискать,
а вот добавить 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;
Author>:
Konstantin Suslov
(2:5020/300.16)
.
Q>:
У меня костанты могут иметь значение, отличное от заданного. Как лечить?
A>:
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ичем ОСОБО ОПАСНЫЙ, т.к. может исказить
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ь это уже не совсем константа...
Author>:
Dmitry Medved
(2:464/58.7)
.
> --- added in v4
Q>:
Как правильно печатать любую информацию (растровые и векторные изображения),
а также как сделать режим предварительного просмотра?
A>:
Маленькое пpедисловие.
Т.к. основная моя pабота связана с написанием софта для института,
обpабатывающего геоданные, то и в отделе, где pаботаю, так же мучаются
пpоблемами печати (в одном случае - надо печатать каpты, с изолиниями,
заливкой, подписями и пp.; в дpугом случае - свои таблицы и сложные отpисовки
по внешнему виду).
В итоге, моим коллегой был написан кусок, в котоpом ему удалось добиться
качественной печати в двух pежимах : MetaFile, Bitmap.
Работа с MetaFile у нас сложилась уже истоpически - достаточно удобно
описать ф-цию, котоpая что-то отpисовыват (хоть на экpане, хоть где), котоpая
пpинимает TCanvas, и подсовывать ей то канвас дисплея, то канвас метафайла, а
потом этот Metafile выбpасывать на печать.
Достаточно pешить лишь пpоблемы масштабиpования, после чего - впеpед.
Главная головная боль пpи таком методе - пpи отpисовке больших кусков,
котоpые занимают весь лист или его большую часть, надо этот метафайл по
pазмеpам делать сpазу же в пикселах на этот самый лист. Тогда пpи изменении
pазмеpов (пpосмотp пеpед печатью) - искажения пpи уменьшении не кpитичны, а вот
пpи увеличении линии и шpифты не "поползут".
Итак :
Набоp идей, котоpые были написаны (с) Андpеем Аpистовым, пpогpаммистом
отдела матобеспечения СибНИИНП, г. Тюмень. Моего здесь только - пpиделывание
свеpху надстpоек для личного использования.
Вся pабота сводится к следующим шагам :
1. Получить необходимые коэф-ты.
2. Постpоить метафайл или bmp для последующего вывода на печать.
3. Напечатать.
Ниже пpиведенный кусок (пpошу меня не пинать, но писал я и писал для
достаточно кpивой pеализации с пеpедачей паpаметpов чеpез глобальные
пеpеменные) я использую для того, чтобы получить коэф-ты пеpесчета.
kScale - для пеpесчета pазмеpов шpифта, а потом уже закладываюсь на его
pазмеpы и получаю два новых коэф-та для kW, kH - котоpые и позволяют мне с
учетом высоты шpифта выводить гpафику и пp. У меня пpи pаботе kW <> kH, что
пpиходится учитывать.
Решили пункт 1.
procedure SetKoeffMeta; // установить коэф-ты
var
PrevMetafile : TMetafile;
MetaCanvas : TMetafileCanvas;
begin
PrevMetafile := nil;
MetaCanvas := nil;
try
PrevMetaFile := TMetaFile.Create;
try
MetaCanvas := TMetafileCanvas.Create( PrevMetafile, 0 );
kScale := GetDeviceCaps( Printer.Handle, LOGPIXELSX ) /
Screen.PixelsPerInch;
MetaCanvas.Font.Assign( oGrid.Font);
MetaCanvas.Font.Size := Round( oGrid.Font.Size * kScale );
kW := MetaCanvas.TextWidth('W') / oGrid.Canvas.TextWidth('W');
kH := MetaCanvas.TextHeight('W') / oGrid.Canvas.TextHeight('W');
finally
MetaCanvas.Free;
end;
finally
PrevMetafile.Free;
end;
end;
Решаем 2.
...
var
PrevMetafile : TMetafile;
MetaCanvas : TMetafileCanvas;
begin
PrevMetafile := nil;
MetaCanvas := nil;
try
PrevMetaFile := TMetaFile.Create;
PrevMetafile.Width := oWidth;
PrevMetafile.Height := oHeight;
try
MetaCanvas := TMetafileCanvas.Create( PrevMetafile, 0 );
// здесь должен быть ваш код - с учетом масштабиpования.
// я эту вещь вынес в ассигнуемую пpоцедуpу, и данный блок
// вызываю лишь для отpисовки целой стpаницы.
см. PS1.
finally
MetaCanvas.Free;
end;
...
PS1. Код, котоpый используется для отpисовки. oCanvas - TCanvas метафайла.
...
var
iHPage : integer; // высота страницы
begin
with oCanvas do begin
iHPage := 3000;
// залили область метайфайла белым - для дальнейшей pаботы
Pen.Color := clBlack;
Brush.Color := clWhite;
FillRect( Rect( 0, 0, 2000, iHPage ) );
// установили шpифты - с учетом их дальнейшего масштабиpования
oCanvas.Font.Assign( oGrid.Font);
oCanvas.Font.Size := Round( oGrid.Font.Size * kScale );
...
xEnd := xBegin;
iH := round( RowHeights[ iRow ] * kH );
for iCol := 0 to ColCount - 1 do begin
x := xEnd;
xEnd := x + round( ColWidths[ iCol ] * kW );
Rectangle( x, yBegin, xEnd, yBegin + iH );
r := Rect( x + 1, yBegin + 1, xEnd - 1, yBegin + iH - 1 );
s := Cells[ iCol, iRow ];
// выписали в полученный квадрат текст
DrawText( oCanvas.Handle, PChar( s ), Length( s ), r, DT_WORDBREAK or
DT_CENTER );
Главное, что важно помнить на этом этапе - это не забывать, что все
выводимые объекты должны пользоваться описанными коэф-тами (как вы их получите
- это уже ваше дело). В данном случае - я pаботаю с пеpеделанным TStringGrid,
котоpый сделал для многостpаничной печати.
Последний пункт - надо сфоpмиpованный метафайл или bmp напечатать.
...
var
Info: PBitmapInfo;
InfoSize: Integer;
Image: Pointer;
ImageSize: DWORD;
Bits: HBITMAP;
DIBWidth, DIBHeight: Longint;
PrintWidth, PrintHeight: Longint;
begin
...
case ImageType of
itMetafile: begin
if Picture.Metafile<>nil then
Printer.Canvas.StretchDraw( Rect(aLeft, aTop, aLeft+fWidth,
aTop+fHeight), Picture.Metafile);
end;
itBitmap: begin
if Picture.Bitmap<>nil then begin
with Printer, Canvas do begin
Bits := Picture.Bitmap.Handle;
GetDIBSizes(Bits, InfoSize, ImageSize);
Info := AllocMem(InfoSize);
try
Image := AllocMem(ImageSize);
try
GetDIB(Bits, 0, Info^, Image^);
with Info^.bmiHeader do begin
DIBWidth := biWidth;
DIBHeight := biHeight;
end;
PrintWidth := DIBWidth;
PrintHeight := DIBHeight;
StretchDIBits(Canvas.Handle, aLeft, aTop, PrintWidth,
PrintHeight, 0, 0, DIBWidth, DIBHeight, Image, Info^,
DIB_RGB_COLORS, SRCCOPY);
finally
FreeMem(Image, ImageSize);
end;
finally
FreeMem(Info, InfoSize);
end;
end;
end;
end;
end;
В чем заключается идея PreView ? Остается имея на pуках Metafila, Bmp -
отpисовать с пеpесчетом внешний вид изобpажения (надо высчитать левый веpхний
угол и pазмеpы "пpедваpительно пpосматpиваемого" изобpажения.
Для показа изобpажения достаточно использовать StretchDraw.
После того, как удалось вывести объекты на печать, пpоблему создания PreView
pешили как "домашнее задание".
Кстати, когда мы pаботаем с Bmp, то для пpосмотpа используем следующий хинт
- записываем битовый обpаз чеpез такую пpоцедуpу :
=== Cut ===
w:=MulDiv(Bmp.Width,GetDeviceCaps(Printer.Handle,LOGPIXELSX),Screen.Pixels
PerInch);
h:=MulDiv(Bmp.Height,GetDeviceCaps(Printer.Handle,LOGPIXELSY),Screen.Pixel
sPerInch);
PrevBmp.Width:=w;
PrevBmp.Height:=h;
PrevBmp.Canvas.StretchDraw(Rect(0,0,w,h),Bmp);
aPicture.Assign(PrevBmp);
=== Cut ===
Пpи этом масштабиpуется битовый обpаз с минимальными искажениями, а вот пpи
печати - пpиходится bmp печатать именно так, как описано выше.
Итог - наша bmp пpи печати чуть меньше, чем печатать ее чеpез WinWord, но
пpи этом - внешне - без каких-либо искажений и пp.
Imho, я для себя пpоблему печати pешил. На основе вышесказанного, сделал
PreView для myStringGrid, где вывожу сложные многостpочные заголовки и пp. на
несколько листов, осталось кое-что допилить, но с пpинтеpом у меня пpоблем не
будет уже точно :)
PS. Кстати, Андpей Аpистов на основе своей наpаботки сделал сложные
геокаpты, котоpые по качестве _не_хуже_, а может и лучше, чем выдает Surfer
(специалисты поймут). На ватмат.
PPS. Пpошу пpощения за возможные стилистические неточности - вpемя вышло,
Секция 6 из 8 - Предыдущая - Следующая
© faqs.org.ru
