Как послать сообщение?
Как послать сообщение?
{
You need 3 TEdits, 1 TMemo und 1 TClientSocket.
Set the TClientsocket's Port to 80 and the Host to wwp.mirabilis.com.
}
var
Form1: TForm1;
csend: string;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
begin
cSend := 'POST http://wwp.icq.com/scripts/WWPMsg.dll HTTP/2.0' + chr(13) + chr(10);
cSend := cSend + 'Referer: http://wwp.mirabilis.com' + chr(13) + chr(10);
cSend := cSend + 'User-Agent: Mozilla/4.06 (Win95; I)' + chr(13) + chr(10);
cSend := cSend + 'Connection: Keep-Alive' + chr(13) + chr(10);
cSend := cSend + 'Host: wwp.mirabilis.com:80' + chr(13) + chr(10);
cSend := cSend + 'Content-type: application/x-www-form-urlencoded' + chr(13) + chr(10);
cSend := cSend + 'Content-length:8000' + chr(13) + chr(10);
cSend := cSend + 'Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, */*' +
chr(13) + chr(10) + chr(13) + chr(10);
cSend := cSend + 'from=' + edit1.Text + ' &fromemail=' + edit2.Text +
' &fromicq:110206786' + ' &body=' + memo1.Text + ' &to=' + edit3.Text + '&Send=';
clientsocket1.Active := True;
end;
procedure TForm1.ClientSocket1Connect(Sender: TObject;
Socket: TCustomWinSocket);
begin
clientsocket1.Socket.SendText(csend);
clientsocket1.Active := False;
end;
Взято с сайта
Как послать сообщение всем окнам Windows?
Как послать сообщение всем окнам 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.
АвторAndrey Burov
(2:463/238.19)
Автор:
StayAtHomeВзято из
Как повернуть Bitmap на любой угол
Как повернуть Bitmap на любой угол
ConstPixelMax = 32768;
Type
pPixelArray = ^TPixelArray;
TPixelArray = Array[0..PixelMax-1] Of TRGBTriple;
Procedure RotateBitmap_ads(
SourceBitmap : TBitmap;
out DestBitmap : TBitmap;
Center : TPoint;
Angle : Double);
Var
cosRadians : Double;
inX : Integer;
inXOriginal : Integer;
inXPrime : Integer;
inXPrimeRotated : Integer;
inY : Integer;
inYOriginal : Integer;
inYPrime : Integer;
inYPrimeRotated : Integer;
OriginalRow : pPixelArray;
Radians : Double;
RotatedRow : pPixelArray;
sinRadians : Double;
begin
DestBitmap.Width := SourceBitmap.Width;
DestBitmap.Height := SourceBitmap.Height;
DestBitmap.PixelFormat := pf24bit;
Radians := -(Angle) * PI / 180;
sinRadians := Sin(Radians);
cosRadians := Cos(Radians);
For inX := DestBitmap.Height-1 Downto 0 Do
Begin
RotatedRow := DestBitmap.Scanline[inX];
inXPrime := 2*(inX - Center.y) + 1;
For inY := DestBitmap.Width-1 Downto 0 Do
Begin
inYPrime := 2*(inY - Center.x) + 1;
inYPrimeRotated := Round(inYPrime * CosRadians - inXPrime * sinRadians);
inXPrimeRotated := Round(inYPrime * sinRadians + inXPrime * cosRadians);
inYOriginal := (inYPrimeRotated - 1) Div 2 + Center.x;
inXOriginal := (inXPrimeRotated - 1) Div 2 + Center.y;
If
(inYOriginal >= 0) And
(inYOriginal <= SourceBitmap.Width-1) And
(inXOriginal >= 0) And
(inXOriginal <= SourceBitmap.Height-1)
Then
Begin
OriginalRow := SourceBitmap.Scanline[inXOriginal];
RotatedRow[inY] := OriginalRow[inYOriginal]
End
Else
Begin
RotatedRow[inY].rgbtBlue := 255;
RotatedRow[inY].rgbtGreen := 0;
RotatedRow[inY].rgbtRed := 0
End;
End;
End;
End;
{Usage:}
procedure TForm1.Button1Click(Sender: TObject);
Var
Center : TPoint;
Bitmap : TBitmap;
begin
Bitmap := TBitmap.Create;
Try
Center.y := (Image.Height div 2)+20;
Center.x := (Image.Width div 2)+0;
RotateBitmap_ads(
Image.Picture.Bitmap,
Bitmap,
Center,
Angle);
Angle := Angle + 15;
Image2.Picture.Bitmap.Assign(Bitmap);
Finally
Bitmap.Free;
End;
end;
Взято с Исходников.ru
procedure RotateBitmap(Bitmap: TBitmap; Angle: Double; BackColor: TColor);
type TRGB = record
B, G, R: Byte;
end;
pRGB = ^TRGB;
pByteArray = ^TByteArray;
TByteArray = array[0..32767] of Byte;
TRectList = array [1..4] of TPoint;
var x, y, W, H, v1, v2: Integer;
Dest, Src: pRGB;
VertArray: array of pByteArray;
Bmp: TBitmap;
procedure SinCos(AngleRad: Double; var ASin, ACos: Double);
begin
ASin := Sin(AngleRad);
ACos := Cos(AngleRad);
end;
function RotateRect(const Rect: TRect; const Center: TPoint; Angle: Double): TRectList;
var DX, DY: Integer;
SinAng, CosAng: Double;
function RotPoint(PX, PY: Integer): TPoint;
begin
DX := PX - Center.x;
DY := PY - Center.y;
Result.x := Center.x + Round(DX * CosAng - DY * SinAng);
Result.y := Center.y + Round(DX * SinAng + DY * CosAng);
end;
begin
SinCos(Angle * (Pi / 180), SinAng, CosAng);
Result[1] := RotPoint(Rect.Left, Rect.Top);
Result[2] := RotPoint(Rect.Right, Rect.Top);
Result[3] := RotPoint(Rect.Right, Rect.Bottom);
Result[4] := RotPoint(Rect.Left, Rect.Bottom);
end;
function Min(A, B: Integer): Integer;
begin
if A < B then Result := A
else Result := B;
end;
function Max(A, B: Integer): Integer;
begin
if A > B then Result := A
else Result := B;
end;
function GetRLLimit(const RL: TRectList): TRect;
begin
Result.Left := Min(Min(RL[1].x, RL[2].x), Min(RL[3].x, RL[4].x));
Result.Top := Min(Min(RL[1].y, RL[2].y), Min(RL[3].y, RL[4].y));
Result.Right := Max(Max(RL[1].x, RL[2].x), Max(RL[3].x, RL[4].x));
Result.Bottom := Max(Max(RL[1].y, RL[2].y), Max(RL[3].y, RL[4].y));
end;
procedure Rotate;
var x, y, xr, yr, yp: Integer;
ACos, ASin: Double;
Lim: TRect;
begin
W := Bmp.Width;
H := Bmp.Height;
SinCos(-Angle * Pi/180, ASin, ACos);
Lim := GetRLLimit(RotateRect(Rect(0, 0, Bmp.Width, Bmp.Height), Point(0, 0), Angle));
Bitmap.Width := Lim.Right - Lim.Left;
Bitmap.Height := Lim.Bottom - Lim.Top;
Bitmap.Canvas.Brush.Color := BackColor;
Bitmap.Canvas.FillRect(Rect(0, 0, Bitmap.Width, Bitmap.Height));
for y := 0 to Bitmap.Height - 1 do begin
Dest := Bitmap.ScanLine[y];
yp := y + Lim.Top;
for x := 0 to Bitmap.Width - 1 do begin
xr := Round(((x + Lim.Left) * ACos) - (yp * ASin));
yr := Round(((x + Lim.Left) * ASin) + (yp * ACos));
if (xr > -1) and (xr < W) and (yr > -1) and (yr < H) then begin
Src := Bmp.ScanLine[yr];
Inc(Src, xr);
Dest^ := Src^;
end;
Inc(Dest);
end;
end;
end;
begin
Bitmap.PixelFormat := pf24Bit;
Bmp := TBitmap.Create;
try
Bmp.Assign(Bitmap);
W := Bitmap.Width - 1;
H := Bitmap.Height - 1;
if Frac(Angle) <> 0.0
then Rotate
else
case Trunc(Angle) of
-360, 0, 360, 720: Exit;
90, 270: begin
Bitmap.Width := H + 1;
Bitmap.Height := W + 1;
SetLength(VertArray, H + 1);
v1 := 0;
v2 := 0;
if Angle = 90.0 then v1 := H
else v2 := W;
for y := 0 to H do VertArray[y] := Bmp.ScanLine[Abs(v1 - y)];
for x := 0 to W do begin
Dest := Bitmap.ScanLine[x];
for y := 0 to H do begin
v1 := Abs(v2 - x)*3;
with Dest^ do begin
B := VertArray[y, v1];
G := VertArray[y, v1+1];
R := VertArray[y, v1+2];
end;
Inc(Dest);
end;
end
end;
180: begin
for y := 0 to H do begin
Dest := Bitmap.ScanLine[y];
Src := Bmp.ScanLine[H - y];
Inc(Src, W);
for x := 0 to W do begin
Dest^ := Src^;
Dec(Src);
Inc(Dest);
end;
end;
end;
else Rotate;
end;
finally
Bmp.Free;
end;
end;
// Использование
RotateBitmap(Image1.Picture.Bitmap, StrToInt(Edit1.Text), clWhite);
Взято из
Как повернуть элипс?
Как повернуть элипс?
procedureTForm1.EllipseAngle(ACanvas: TCanvas; XCenter, YCenter,
XRadius, YRadius: Integer; Angle: Integer);
const
Step = 49;
var
RX, RY: Integer;
i: Integer;
Theta: Double;
SAngle, CAngle: Double;
RotAngle: Double;
XC, YC: Integer;
Kf: Double;
X, Y: Double;
XRot, YRot: Integer;
Points: array[0..Step] of TPoint;
begin
RotAngle := Angle * PI / 180;
Kf := (360 * PI / 180) / Step;
SAngle := Sin(RotAngle);
CAngle := Cos(RotAngle);
for i := 0 to Step do
begin
Theta := i * Kf;
X := XCenter + XRadius * Cos(Theta);
Y := YCenter + YRadius * Sin(Theta);
XRot := Round(XCenter + (X - XCenter) * CAngle - (Y - YCenter) * SAngle);
YRot := Round(YCenter + (X - XCenter) * SAngle + (Y - YCenter) * CAngle);
Points[i] := Point(XRot, YRot);
end;
ACanvas.Polygon(Points);
end;
procedure RotatedEllipse(aCanvas: TCanvas; X1, Y1, X2, Y2: Integer);
var
T, O: TXForm; {in unit Windows}
begin
{ ... }
SetGraphicsMode(aCanvas.Handle, GM_Advanced);
GetWorldTransform(aCanvas.Handle, O);
{Angle in degree}
T.eM11 := 1 * Cos(w / 360 * Pi * 2);
T.eM22 := 1 * Cos(w / 360 * Pi * 2);
T.eM12 := 1 * Sin(w / 360 * Pi * 2);
T.eM21 := 1 * -Sin(w / 360 * Pi * 2);
T.eDX := Round((X1 + X2) / 2);
T.eDY := Round((Y1 + Y2) / 2);
ModifyWorldTransform(aCanvas.Handle, T, MWT_LEFTMULTIPLY);
Canvas.Ellipse(X1, Y1, X2, Y2);
SetWorldTransform(TheDraw.Handle, O);
end;
Взято с
Delphi Knowledge BaseКак пpинимать яpлыки пpи пеpетягивании их на контpол
Как пpинимать яpлыки пpи пеpетягивании их на контpол
Автор: Nomadic
TForm1= class(TForm)
...
private
{ Private declarations }
procedure WMDropFiles(var M: TWMDropFiles); message WM_DROPFILES;
...
end;
var
Form1: TForm1;
implementation
uses
StrUtils, ShellAPI, ComObj, ShlObj, ActiveX;
procedure TForm1.FormCreate(Sender: TObject);
begin
...
DragAcceptFiles(Handle, True);
...
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
...
DragAcceptFiles(Handle, False);
...
end;
procedure TForm1.WMDropFiles(var M: TWMDropFiles);
var
hDrop: Cardinal;
n: Integer;
s: string;
begin
hDrop := M.Drop;
n := DragQueryFile(hDrop, 0, nil, 0);
SetLength(s, n);
DragQueryFile(hDrop, 0, PChar(s), n + 1);
DragFinish(hDrop);
M.Result := 0;
FileOpen(s);
end;
procedure TForm1.FileOpen(FileName: string);
begin
if CompareText(ExtractFileExt(FileName), '.lnk') = 0 then
FileName := ResolveShortcut(Application.Handle, FileName);
DocName := ExtractFileName(FileName);
Caption := Application.Title + ' - ' + DocName;
...
end;
function ResolveShortcut(Wnd: HWND; ShortcutPath: string): string;
var
obj: IUnknown;
isl: IShellLink;
ipf: IPersistFile;
pfd: TWin32FindDataA;
begin
Result := '';
obj := CreateComObject(CLSID_ShellLink);
isl := obj as IShellLink;
ipf := obj as IPersistFile;
ipf.Load(PWChar(WideString(ShortcutPath)), STGM_READ);
with isl do
begin
Resolve(Wnd, SLR_ANY_MATCH);
SetLength(Result, MAX_PATH);
GetPath(PChar(Result), Length(Result), pfd, SLGP_UNCPRIORITY);
Result := PChar(Result);
end;
end;
Взято с
Как правильно печатать любую информацию
Как правильно печатать любую информацию (растровые и векторные изображения), а также как сделать режим предварительного просмотра?
Маленькое п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ифты не "поползут".
Итак :
Hабоp идей, котоpые были написаны (с) Андpеем Аpистовым, пpогpаммистом
отдела матобеспечения СибHИИHП, г. Тюмень. Моего здесь только - пpиделывание
свеpху надстpоек для личного использования.
Вся pабота сводится к следующим шагам :
1. Получить необходимые коэф-ты.
2. Постpоить метафайл или bmp для последующего вывода на печать.
3. Hапечатать.
Hиже п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у :
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);
Пpи этом масштабиpуется битовый обpаз с минимальными искажениями, а вот пpи
печати - пpиходится bmp печатать именно так, как описано выше.
Итог - наша bmp пpи печати чуть меньше, чем печатать ее чеpез WinWord, но
пpи этом - внешне - без каких-либо искажений и пp.
Imho, я для себя пpоблему печати pешил. Hа основе вышесказанного, сделал
PreView для myStringGrid, где вывожу сложные многостpочные заголовки и пp. на
несколько листов, осталось кое-что допилить, но с пpинтеpом у меня пpоблем не
будет уже точно :)
PS. Кстати, Андpей Аpистов на основе своей наpаботки сделал сложные
геокаpты, котоpые по качестве _не_хуже_, а может и лучше, чем выдает Surfer
(специалисты поймут). Hа ватмат.
PPS. Пpошу пpощения за возможные стилистические неточности - вpемя вышло,
охpана уже pугается. Hо код - выдpан из pаботающих исходников.
Боpисов Олег Hиколаевич (ZB)
panterra@sbtx.tmn.ru
(2:5077/5)
Взято с сайта
Как правильно работать с прозрачными окнами?
Как правильно работать с прозрачными окнами?
Как правильно работать с прозрачными окнами (стиль WS_EX_TRANSPARENT)?
Стиль окна-формы указывается в CreateParams. Только вот когда перемещаешь его, фон остается со старым куском экрана. Чтобы этого не происходило, то когда pисуешь своё окно, запоминай, что было под ним,а пpи пеpемещении восстанавливай.
HDC hDC = GetDC(GetDesktopWindow()) тебе поможет..
Andrei Bogomolov
http://cardy.hypermart.net
ICQ UIN:7329451
admin@cardy.hypermart.net
e-pager: 7329451@pager.mirabilis.com
(2:5013/11.3)
Автор:
StayAtHomeВзято из
Как предотвратить появление login dialog?
Как предотвратить появление login dialog?
To bypass the login dialog when connecting to a server database, use the property LoginPrompt.You will have to provide the username & password at runtime, but you also can set that up at design time in the object inspector, property Params.
This short source code shows how to do it:
Database1.LoginPrompt:= false;
with Database1.Params do
begin
Clear;
// the parameters SYSDBA & masterkey should be
// retrieved somewhat different :-)
Add('USER NAME=SYSDBA');
Add('PASSWORD=masterkey');
end;
Database1.Connected := tr
Взято с
Delphi Knowledge BaseКак предотвратить утечки памяти при возникновении ошибок?
Как предотвратить утечки памяти при возникновении ошибок?
Используйте конструкцию
Try
{здесь вы пишите код в котором может произойти ошибка}
Finally
{здесь вы пишите код который выполнится в любом случае - хоть произойдёт ошибка, хоть нет}
End
Например, это часто применяется во избежание утечек при динамическом распределении памяти:
t:TStringList;
...
t:=TStringList.create; //распределили память под объект t
Try
{здесь работаем с переменной t}
Finally
t.free;//память выделенная под объект t всегда будет освобождена
End
Автор Vit
Как представить число в другой системе счисления?
Как представить число в другой системе счисления?
function BaseConvert(NumIn: string; BaseIn: Byte; BaseOut: Byte): string;
var
i: integer;
currentCharacter: char;
CharacterValue: Integer;
PlaceValue: Integer;
RunningTotal: Double;
Remainder: Double;
BaseOutDouble: Double;
NumInCaps: string;
s: string;
begin
if (NumIn = '') or (BaseIn < 2) or (BaseIn > 36) or (BaseOut < 1) or (BaseOut > 36) then
begin
Result := 'Error';
Exit;
end;
NumInCaps := UpperCase(NumIn);
PlaceValue := Length(NumInCaps);
RunningTotal := 0;
for i := 1 to Length(NumInCaps) do
begin
PlaceValue := PlaceValue - 1;
CurrentCharacter := NumInCaps[i];
CharacterValue := 0;
if (Ord(CurrentCharacter) > 64) and (Ord(CurrentCharacter) < 91) then
CharacterValue := Ord(CurrentCharacter) - 55;
if CharacterValue = 0 then
if (Ord(CurrentCharacter) < 48) or (Ord(CurrentCharacter) > 57) then
begin
BaseConvert := 'Error';
Exit;
end
else
CharacterValue := Ord(CurrentCharacter);
if (CharacterValue < 0) or (CharacterValue > BaseIn - 1) then
begin
BaseConvert := 'Error';
Exit;
end;
RunningTotal := RunningTotal + CharacterValue * (Power(BaseIn, PlaceValue));
end;
while RunningTotal > 0 do
begin
BaseOutDouble := BaseOut;
Remainder := RunningTotal - (int(RunningTotal / BaseOutDouble) * BaseOutDouble);
RunningTotal := (RunningTotal - Remainder) / BaseOut;
if Remainder >= 10 then
CurrentCharacter := Chr(Trunc(Remainder + 55))
else
begin
s := IntToStr(trunc(remainder));
CurrentCharacter := s[Length(s)];
end;
Result := CurrentCharacter + Result;
end;
end;
// Example, Beispiel
procedure TForm1.Button1Click(Sender: TObject);
begin
BaseConvert('FFFF', 16, 10);
// returns, ergibt '65535'.
end;
Взято с сайта
Решение от Борланд:
The following function will convert a number from one base to
a number of another base:
procedure RadixStr(NumStr : pChar;
Radix : LongInt;
ResultStr : pChar;
NewRadix : LongInt;
var ErrorCode : LongInt);
The RadixStr() function takes a pointer to a null terminated string
containing a number of one base, and fills a buffer with a null
terminated string containing the number converted to another base.
Parameters:
NumStr: A pointer to a null terminated string containing the numeric
string to convert:
Radix: The base of the number contained in the NumStr parameter. The
base must be in the range of 2 to 36;
ResultStr : A pointer to a null terminated string buffer to place the
resulting numeric string. The buffer should be sufficiently large to
hold the resulting string.
NewRadix: The base to use in the conversion. The base must be in the
range of 2 to 36;
ErrorCode: Upon return, contains the return code 0 if successful, or
the character number of the offending character contained in the
buffer NumStr.
Examples of calling the RadixStr() function:
{Convert Hex to Decimal}
RadixStr('FF',
16,
lpBuffer,
10,
Code);
Should return the string '255' in lpbuffer^.
{Convert Decimal to Binary}
RadixStr('255',
10,
lpBuffer,
2,
Code);
Should return the string '11111111' in lpbuffer^.
{Convert Hex to Octal}
RadixStr('FF',
16,
lpBuffer,
8,
Code);
Should return the string '377' in lpbuffer^.
{Function code}
procedure RadixStr(NumStr : pChar;
Radix : LongInt;
ResultStr : pChar;
NewRadix : LongInt;
var ErrorCode : LongInt);
var
RadixChar : array[0..35] of Char;
v : LongInt;
i : LongInt;
p : LongInt;
c : Integer;
begin
if ((Abs(Radix) < 2) or
(Abs(Radix) > 36)) then begin
ErrorCode := p;
Exit;
end;
StrLCopy(ResultStr, NumStr, StrLen(NumStr));
for i := 0 to 35 do begin
if i <= 9 then
RadixChar[i] := Char(48 + (i))
else
RadixChar[i] := Char(64 + (i - 9))
end;
v := 0;
for i := 0 to (StrLen(ResultStr) - 1) do begin
ResultStr[i] := UpCase(ResultStr[i]);
p := Pos(ResultStr[i], PChar(@RadixChar)) - 1;
if ((p < 0) or
(p >= Abs(Radix))) then begin
ErrorCode := i;
Exit;
end;
v := v * Abs(Radix) + p;
end;
if v = 0 then begin
ResultStr := '0';
ErrorCode := 0;
exit;
end else begin
i:=0;
repeat
ResultStr[i] := RadixChar[v mod NewRadix];
v := v div NewRadix;
Inc(i)
until v = 0;
if Radix < 0 then begin
ResultStr[i] := '-';
ResultStr[i + 1] := #0
end else
ResultStr[i] := #0;
p := StrLen(ResultStr);
for i := 0 to ((p div 2) - 1) do begin
ResultStr[i] := Char(Byte(ResultStr[i]) xor
Byte(ResultStr[(p - i) - 1]));
ResultStr[(p - i) - 1] := Char(Byte(ResultStr[(p - i) - 1]) xor
Byte(ResultStr[i]));
ResultStr[i] := Char(Byte(ResultStr[i]) xor
Byte(ResultStr[(p - i) - 1]))
end;
ResultStr[p] := #0;
ErrorCode := 0;
end;
end;
Как преобразовать цвет в оттенки серого
Как преобразовать цвет в оттенки серого
Следущий пример показывает, как преобразовать RGB цвет в аналогичный оттенок серого, наподобие того, как это делает чёрно-белый телевизор:
function RgbToGray(RGBColor : TColor) : TColor;
var
Gray : byte;
begin
Gray := Round((0.30 * GetRValue(RGBColor)) +
(0.59 * GetGValue(RGBColor)) +
(0.11 * GetBValue(RGBColor )));
Result := RGB(Gray, Gray, Gray);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Shape1.Brush.Color := RGB(255, 64, 64);
Shape2.Brush.Color := RgbToGray(Shape1.Brush.Color);
end;
Взято с Исходников.ru
Как преобразовать цвета RGB в CMYK и обратно
Как преобразовать цвета RGB в CMYK и обратно
The following functions RGBTOCMYK() and CMYKTORGB()
demonstrate how to convert between RGB and CMYK color
spaces. Note: There is a direct relationship between RGB
colors and CMY colors. In a CMY color, black tones are
achieved by printing equal amounts of Cyan, Magenta, and
Yellow ink. The black component in a CMY color is achieved
by reducing the CMY components by the minimum of (C, M,
and Y) and substituting pure black in its place producing a
sharper print and using less ink. Since it is possible for a user
to boost the C,M and Y components where boosting the black
component would have been preferable, a ColorCorrectCMYK()
function is provided to achieve the same color by reducing the
C, M and Y components, and boosting the K component.
Example:
procedure RGBTOCMYK(R : byte;
G : byte;
B : byte;
var C : byte;
var M : byte;
var Y : byte;
var K : byte);
begin
C := 255 - R;
M := 255 - G;
Y := 255 - B;
if C < M then
K := C else
K := M;
if Y < K then
K := Y;
if k > 0 then begin
c := c - k;
m := m - k;
y := y - k;
end;
end;
procedure CMYKTORGB(C : byte;
M: byte;
Y : byte;
K : byte;
var R : byte;
var G : byte;
var B : byte);
begin
if (Integer(C) + Integer(K)) < 255 then
R := 255 - (C + K) else
R := 0;
if (Integer(M) + Integer(K)) < 255 then
G := 255 - (M + K) else
G := 0;
if (Integer(Y) + Integer(K)) < 255 then
B := 255 - (Y + K) else
B := 0;
end;
procedure ColorCorrectCMYK(var C : byte;
var M : byte;
var Y : byte;
var K : byte);
var
MinColor : byte;
begin
if C < M then
MinColor := C else
MinColor := M;
if Y < MinColor then
MinColor := Y;
if MinColor + K > 255 then
MinColor := 255 - K;
C := C - MinColor;
M := M - MinColor;
Y := Y - MinColor;
K := K + MinColor;
end;
Автор: p0s0l
Как преобразовать длинный IP адрес в короткий адрес / порт ?
Как преобразовать длинный IP адрес в короткий адрес / порт ?
Некоторые старые internet протоколы ( такие как FTP ) посылают IP адреса и номера портов в шестизначном формате XXX.XXX.XXX.XXX.XX.XXX Следующий код позволяет преобразовать такой адрес к нормальному четырёхзначному IP адресу.
procedure LongIPToShort(aLongIPAddress: string; out ShortIPAddress: string; out PortNumber: Integer);
var I, DotPos, tempPort: Integer;
var tempAddy, temp: string;
var TempStr: string;
begin
tempAddy := '';
tempStr := '';
// Определяем, какой символ использует отправитель в качестве разделителя длинного IP: , или .
if (POS(',', aLongIPAddress) <> 0) then
TempStr := ','
else
TempStr := '.';
for I := 1 to 4 do
begin
DotPOS := POS(TempStr, aLongIPAddress);
tempAddy := tempAddy + (Copy(aLongIPAddress, 1, (DotPos - 1)));
if I <> 4 then TempADdy := TempAddy + '.';
Delete(aLongIpAddress, 1, DotPos);
end;
DotPos := Pos(TempStr, aLongIpAddress);
temp := Copy(aLongIpAddress, 1, (DotPos - 1));
tempPort := (StrToInt(temp) * 256);
Delete(aLongIpAddress, 1, DotPos);
TempPort := tempPort + StrToInt(ALongIpAddress);
ShortIPAddress := TempADdy;
PortNumber := tempPort;
end;
Взято с Исходников.ru
Как преобразовать http://192.168.1.2 в http://3232235778 ?
Как преобразовать http://192.168.1.2 в http://3232235778 ?
Автор: Roni Havas
Функция, представленная в этом примере может быть и не очень элегантна, зато работает. Функция получает в качестве параметра строку, содержащую IP адрес, и возвращает строку с IP адресом в виде DWord значения. Результат легко можно проверить командой "Ping".
Совместимость: Delphi (все версии)
Обратите внимание, что необходимо добавить "Math" в "Uses" для функции "IntPower";
function IP2HEX(OrgIP: string): string;
var OrgVal: string; // Сохраняем оригинальное значение IP адреса
O1, O2, O3, O4: string; // части оригинального IP
H1, H2, H3, H4: string; // шестнадцатиричные части
HexIP: string; // Здесь будут собраны все шестнадцатиричные части
XN: array[1..8] of Extended;
Flt1: Extended;
Xc: Integer;
begin
// Сохраняем в обратном порядке для простого случая
Xn[8] := IntPower(16, 0); Xn[7] := IntPower(16, 1); Xn[6] := IntPower(16, 2); Xn[5] := IntPower(16, 3);
Xn[4] := IntPower(16, 4); Xn[3] := IntPower(16, 5); Xn[2] := IntPower(16, 6); Xn[1] := IntPower(16, 7);
// Сохраняем оригинальный IP адрес
OrgVal := OrgIP;
O1 := Copy(OrgVal, 1, Pos('.', OrgVal) - 1); Delete(OrgVal, 1, Pos('.', OrgVal));
O2 := Copy(OrgVal, 1, Pos('.', OrgVal) - 1); Delete(OrgVal, 1, Pos('.', OrgVal));
O3 := Copy(OrgVal, 1, Pos('.', OrgVal) - 1); Delete(OrgVal, 1, Pos('.', OrgVal));
O4 := OrgVal;
H1 := IntToHex(StrToInt(O1), 2); H2 := IntToHex(StrToInt(O2), 2);
H3 := IntToHex(StrToInt(O3), 2); H4 := IntToHex(StrToInt(O4), 2);
// Получаем шестнадцатиричное значение IP адреса
HexIP := H1 + H2 + H3 + H4;
// Преобразуем это большое шестнадцатиричное значение в переменную Float
Flt1 := 0;
for Xc := 1 to 8 do
begin
case HexIP[Xc] of
'0'..'9': Flt1 := Flt1 + (StrToInt(HexIP[XC]) * Xn[Xc]);
'A': Flt1 := Flt1 + (10 * Xn[Xc]);
'B': Flt1 := Flt1 + (11 * Xn[Xc]);
'C': Flt1 := Flt1 + (12 * Xn[Xc]);
'D': Flt1 := Flt1 + (13 * Xn[Xc]);
'E': Flt1 := Flt1 + (14 * Xn[Xc]);
'F': Flt1 := Flt1 + (15 * Xn[Xc]);
end;
end;
Result := FloatToStr(Flt1);
end;
Взято с Исходников.ru
Как преобразовать шестнадцатиричный цвет HTML в TColor
Как преобразовать шестнадцатиричный цвет HTML в TColor
unitcolours;
interface
uses
Windows, Sysutils, Graphics;
function ConvertHtmlHexToTColor(Color: string):TColor ;
function CheckHexForHash(col: string):string ;
implementation
function ConvertHtmlHexToTColor(Color: string):TColor ;
var
rColor: TColor;
begin
Color := CheckHexForHash(Color);
if (length(color) >= 6) then
begin
{незабудьте, что TColor это bgr, а не rgb: поэтому необходимо изменить порядок}
color := '$00' + copy(color,5,2) + copy(color,3,2) + copy(color,1,2);
rColor := StrToInt(color);
end;
result := rColor;
end;
// Просто проверяет первый сивол строки на наличие '#' и удаляет его, если он найден
function CheckHexForHash(col: string):string ;
begin
if col[1] = '#' then
col := StringReplace(col,'#','',[rfReplaceAll]);
result := col;
end;
end.
Взято из
Как преобразовать String в Binary и наоборот?
Как преобразовать String в Binary и наоборот?
Автор: Rem
functionBinStrToByte(a_sBinStr: string): byte;
var
i: integer;
begin
Result := 0;
for i := 1 to length(a_sBinStr) do
Result := (Result shl 1) or byte(a_sBinStr[i] = '1');
end;
function ByteToBinStr(a_bByte: byte): string;
var
i: integer;
begin
SetLength(Result, 8);
for i := 8 downto 1 do
begin
Result[i] := chr($30 + (a_bByte and 1));
a_bByte := a_bByte shr 1;
end;
end;
// Примечание: вторая функция использует тот факт,
// что в таблице ANSI коды '0' = $30 и '1' = $31
Взято с
Как преобразовать строку в дату?
Как преобразовать строку в дату?
Функция StrToDate преобразует только числа, поэтому, если у Вас месяцы в виде имён, то прийдётся использовать VarToDateTime.
var
D1, D2, D3 : TDateTime;
begin
D1 := VarToDateTime('December 6, 1969');
D2 := VarToDateTime('6-Apr-1998');
D3 := VarToDateTime('1998-Apr-6');
ShowMessage(DateToStr(D1)+' '+DateToStr(D2)+' '+
DateToStr(D3));
end;
Взято с Исходников.ru
When extracting data from text or other operating systems the format of date strings can vary dramatically. Borland function StrToDateTime() converts a string to a TDateTime value, but it is limited to the fact that the string parameter must be in the format of the current locale's date/time format.
eg. "MM/DD/YY HH:MM:SS"
Answer:
This is of little use when extracting dates such as .. 1) "Friday 18 October 2002 08:34am (45 secs)" or "Wednesday 15 May 2002 06:12 (22 secs)"
2) "20020431"
3) "12.Nov.03"
4) "14 Hour 31 Minute 25 Second 321 MSecs"
This function will evaluate a DateTime string in accordance to the DateTime specifier format string supplied. The following specifiers are supported ...
dd the day as a number with a leading zero or space (01-31).
ddd the day as an abbreviation (Sun-Sat)
dddd the day as a full name (Sunday-Saturday)
mm
the month as a number with a leading zero or space (01-12).
mmm
the month as an abbreviation (Jan-Dec)
mmmm the month as a full name (January-December)
yy
the year as a two-digit number (00-99).
yyyy
the year as a four-digit number (0000-9999).
hh
the hour with a leading zero or space (00-23)
nn
the minute with a leading zero or space (00-59).
ss
the second with a leading zero or space (00-59).
zzz
the millisecond with a leading zero (000-999).
ampm
Specifies am or pm flag hours (0..12)
ap Specifies a or p flag hours (0..12)
(Any other character corresponds to a literal or delimiter.)
NOTE : One assumption I have to make is that DAYS, MONTHS, HOURS and MINUTES have a leading ZERO or SPACE (ie. are 2 chars long) and MILLISECONDS are 3 chars long (ZERO or SPACE padded)
Using function
DateTimeStrEval(const DateTimeFormat : string; const DateTimeStr : string) : TDateTime;
The above Examples (1..4) can be evaluated as ... (Assume DT1 to DT4 equals example strings 1..4)
1)
MyDate := DateTimeStrEval('dddd dd mmmm yyyy hh:nnampm (ss xxxx)', DT1);2)
MyDate := DateTimeStrEval('yyyymmdd', DT2);3)
MyDate := DateTimeStrEval('dd-mmm-yy', DT3);4)
MyDate := DateTimeStrEval('hh xxxx nn xxxxxx ss xxxxxx zzz xxxxx', DT4);uses SysUtils, DateUtils
// =============================================================================
// Evaluate a date time string into a TDateTime obeying the
// rules of the specified DateTimeFormat string
// eg. DateTimeStrEval('dd-MMM-yyyy hh:nn','23-May-2002 12:34)
//
// Delphi 6 Specific in DateUtils can be translated to ....
//
// YearOf()
//
// function YearOf(const AValue: TDateTime): Word;
// var LMonth, LDay : word;
// begin
// DecodeDate(AValue,Result,LMonth,LDay);
// end;
//
// TryEncodeDateTime()
//
// function TryEncodeDateTime(const AYear,AMonth,ADay,AHour,AMinute,ASecond,
// AMilliSecond : word;
// out AValue : TDateTime): Boolean;
// var LTime : TDateTime;
// begin
// Result := TryEncodeDate(AYear, AMonth, ADay, AValue);
// if Result then begin
// Result := TryEncodeTime(AHour, AMinute, ASecond, AMilliSecond, LTime);
// if Result then
// AValue := AValue + LTime;
// end;
// end;
//
// (TryEncodeDate() and TryEncodeTime() is the same as EncodeDate() and
// EncodeTime() with error checking and boolean return value)
//
// =============================================================================
function DateTimeStrEval(const DateTimeFormat: string;
const DateTimeStr: string): TDateTime;
var
i, ii, iii: integer;
Retvar: TDateTime;
Tmp,
Fmt, Data, Mask, Spec: string;
Year, Month, Day, Hour,
Minute, Second, MSec: word;
AmPm: integer;
begin
Year := 1;
Month := 1;
Day := 1;
Hour := 0;
Minute := 0;
Second := 0;
MSec := 0;
Fmt := UpperCase(DateTimeFormat);
Data := UpperCase(DateTimeStr);
i := 1;
Mask := '';
AmPm := 0;
while i < length(Fmt) do
begin
if Fmt[i] in ['A', 'P', 'D', 'M', 'Y', 'H', 'N', 'S', 'Z'] then
begin
// Start of a date specifier
Mask := Fmt[i];
ii := i + 1;
// Keep going till not valid specifier
while true do
begin
if ii > length(Fmt) then
Break; // End of specifier string
Spec := Mask + Fmt[ii];
if (Spec = 'DD') or (Spec = 'DDD') or (Spec = 'DDDD') or
(Spec = 'MM') or (Spec = 'MMM') or (Spec = 'MMMM') or
(Spec = 'YY') or (Spec = 'YYY') or (Spec = 'YYYY') or
(Spec = 'HH') or (Spec = 'NN') or (Spec = 'SS') or
(Spec = 'ZZ') or (Spec = 'ZZZ') or
(Spec = 'AP') or (Spec = 'AM') or (Spec = 'AMP') or
(Spec = 'AMPM') then
begin
Mask := Spec;
inc(ii);
end
else
begin
// End of or Invalid specifier
Break;
end;
end;
// Got a valid specifier ? - evaluate it from data string
if (Mask <> '') and (length(Data) > 0) then
begin
// Day 1..31
if (Mask = 'DD') then
begin
Day := StrToIntDef(trim(copy(Data, 1, 2)), 0);
delete(Data, 1, 2);
end;
// Day Sun..Sat (Just remove from data string)
if Mask = 'DDD' then
delete(Data, 1, 3);
// Day Sunday..Saturday (Just remove from data string LEN)
if Mask = 'DDDD' then
begin
Tmp := copy(Data, 1, 3);
for iii := 1 to 7 do
begin
if Tmp = Uppercase(copy(LongDayNames[iii], 1, 3)) then
begin
delete(Data, 1, length(LongDayNames[iii]));
Break;
end;
end;
end;
// Month 1..12
if (Mask = 'MM') then
begin
Month := StrToIntDef(trim(copy(Data, 1, 2)), 0);
delete(Data, 1, 2);
end;
// Month Jan..Dec
if Mask = 'MMM' then
begin
Tmp := copy(Data, 1, 3);
for iii := 1 to 12 do
begin
if Tmp = Uppercase(copy(LongMonthNames[iii], 1, 3)) then
begin
Month := iii;
delete(Data, 1, 3);
Break;
end;
end;
end;
// Month January..December
if Mask = 'MMMM' then
begin
Tmp := copy(Data, 1, 3);
for iii := 1 to 12 do
begin
if Tmp = Uppercase(copy(LongMonthNames[iii], 1, 3)) then
begin
Month := iii;
delete(Data, 1, length(LongMonthNames[iii]));
Break;
end;
end;
end;
// Year 2 Digit
if Mask = 'YY' then
begin
Year := StrToIntDef(copy(Data, 1, 2), 0);
delete(Data, 1, 2);
if Year < TwoDigitYearCenturyWindow then
Year := (YearOf(Date) div 100) * 100 + Year
else
Year := (YearOf(Date) div 100 - 1) * 100 + Year;
end;
// Year 4 Digit
if Mask = 'YYYY' then
begin
Year := StrToIntDef(copy(Data, 1, 4), 0);
delete(Data, 1, 4);
end;
// Hours
if Mask = 'HH' then
begin
Hour := StrToIntDef(trim(copy(Data, 1, 2)), 0);
delete(Data, 1, 2);
end;
// Minutes
if Mask = 'NN' then
begin
Minute := StrToIntDef(trim(copy(Data, 1, 2)), 0);
delete(Data, 1, 2);
end;
// Seconds
if Mask = 'SS' then
begin
Second := StrToIntDef(trim(copy(Data, 1, 2)), 0);
delete(Data, 1, 2);
end;
// Milliseconds
if (Mask = 'ZZ') or (Mask = 'ZZZ') then
begin
MSec := StrToIntDef(trim(copy(Data, 1, 3)), 0);
delete(Data, 1, 3);
end;
// AmPm A or P flag
if (Mask = 'AP') then
begin
if Data[1] = 'A' then
AmPm := -1
else
AmPm := 1;
delete(Data, 1, 1);
end;
// AmPm AM or PM flag
if (Mask = 'AM') or (Mask = 'AMP') or (Mask = 'AMPM') then
begin
if copy(Data, 1, 2) = 'AM' then
AmPm := -1
else
AmPm := 1;
delete(Data, 1, 2);
end;
Mask := '';
i := ii;
end;
end
else
begin
// Remove delimiter from data string
if length(Data) > 1 then
delete(Data, 1, 1);
inc(i);
end;
end;
if AmPm = 1 then
Hour := Hour + 12;
if not TryEncodeDateTime(Year, Month, Day, Hour, Minute, Second, MSec, Retvar) then
Retvar := 0.0;
Result := Retvar;
end;
Взято с
Delphi Knowledge BaseКак преобразовать текст в иконку?
Как преобразовать текст в иконку?
unit unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Timer1: TTimer;
Image1: TImage;
procedure Button1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
private
function StringToIcon(const st: string): HIcon;
public
{ Public declarations }
end;
var
Form1: TForm1;
sss: Integer = 0;
implementation
{$R *.DFM}
type
ICONIMAGE = record
Width, Height, Colors: DWORD; // Ширина, Высота и кол-во цветов
lpBits: PChar; // указатель на DIB биты
dwNumBytes: DWORD; // Сколько байт?
lpbi: PBitmapInfoHeader; // указатель на заголовок
lpXOR: PChar; // указатель на XOR биты изображения
lpAND: PChar; // указатель на AND биты изображения
end;
function CopyColorTable(var lpTarget: BITMAPINFO; const lpSource:
BITMAPINFO): boolean;
var
dc: HDC;
hPal: HPALETTE;
pe: array[0..255] of PALETTEENTRY;
i: Integer;
begin
result := False;
case (lpTarget.bmiHeader.biBitCount) of
8:
if lpSource.bmiHeader.biBitCount = 8 then
begin
Move(lpSource.bmiColors, lpTarget.bmiColors, 256 * sizeof(RGBQUAD));
result := True
end
else
begin
dc := GetDC(0);
if dc <> 0 then
try
hPal := CreateHalftonePalette(dc);
if hPal <> 0 then
try
if GetPaletteEntries(hPal, 0, 256, pe) <> 0 then
begin
for i := 0 to 255 do
begin
lpTarget.bmiColors[i].rgbRed := pe[i].peRed;
lpTarget.bmiColors[i].rgbGreen := pe[i].peGreen;
lpTarget.bmiColors[i].rgbBlue := pe[i].peBlue;
lpTarget.bmiColors[i].rgbReserved := pe[i].peFlags
end;
result := True
end
finally
DeleteObject(hPal)
end
finally
ReleaseDC(0, dc)
end
end;
4:
if lpSource.bmiHeader.biBitCount = 4 then
begin
Move(lpSource.bmiColors, lpTarget.bmiColors, 16 * sizeof(RGBQUAD));
result := True
end
else
begin
hPal := GetStockObject(DEFAULT_PALETTE);
if (hPal <> 0) and (GetPaletteEntries(hPal, 0, 16, pe) <> 0) then
begin
for i := 0 to 15 do
begin
lpTarget.bmiColors[i].rgbRed := pe[i].peRed;
lpTarget.bmiColors[i].rgbGreen := pe[i].peGreen;
lpTarget.bmiColors[i].rgbBlue := pe[i].peBlue;
lpTarget.bmiColors[i].rgbReserved := pe[i].peFlags
end;
result := True
end
end;
1:
begin
i := 0;
lpTarget.bmiColors[i].rgbRed := 0;
lpTarget.bmiColors[i].rgbGreen := 0;
lpTarget.bmiColors[i].rgbBlue := 0;
lpTarget.bmiColors[i].rgbReserved := 0;
i := 1;
lpTarget.bmiColors[i].rgbRed := 255;
lpTarget.bmiColors[i].rgbGreen := 255;
lpTarget.bmiColors[i].rgbBlue := 255;
lpTarget.bmiColors[i].rgbReserved := 0;
result := True
end;
else
result := True
end
end;
function WidthBytes(bits: DWORD): DWORD;
begin
result := ((bits + 31) shr 5) shl 2
end;
function BytesPerLine(const bmih: BITMAPINFOHEADER): DWORD;
begin
result := WidthBytes(bmih.biWidth * bmih.biPlanes * bmih.biBitCount)
end;
function DIBNumColors(const lpbi: BitmapInfoHeader): word;
var
dwClrUsed: DWORD;
begin
dwClrUsed := lpbi.biClrUsed;
if dwClrUsed <> 0 then
result := Word(dwClrUsed)
else
case lpbi.biBitCount of
1: result := 2;
4: result := 16;
8: result := 256
else
result := 0
end
end;
function PaletteSize(const lpbi: BitmapInfoHeader): word;
begin
result := DIBNumColors(lpbi) * sizeof(RGBQUAD)
end;
function FindDIBBits(const lpbi: BitmapInfo): PChar;
begin
result := @lpbi;
result := result + lpbi.bmiHeader.biSize + PaletteSize(lpbi.bmiHeader)
end;
function ConvertDIBFormat(var lpSrcDIB: BITMAPINFO; nWidth, nHeight, nbpp: DWORD; bStretch: boolean):
PBitmapInfo;
var
lpbmi: PBITMAPINFO;
lpSourceBits, lpTargetBits: Pointer;
DC, hSourceDC, hTargetDC: HDC;
hSourceBitmap, hTargetBitmap, hOldTargetBitmap, hOldSourceBitmap:
HBITMAP;
dwSourceBitsSize, dwTargetBitsSize, dwTargetHeaderSize: DWORD;
begin
result := nil;
// Располагаем и заполняем структуру BITMAPINFO для нового DIB
// Обеспе?иваем достато?но места для 256-цветной таблицы
dwTargetHeaderSize := sizeof(BITMAPINFO) + (256 * sizeof(RGBQUAD));
GetMem(lpbmi, dwTargetHeaderSize);
try
lpbmi^.bmiHeader.biSize := sizeof(BITMAPINFOHEADER);
lpbmi^.bmiHeader.biWidth := nWidth;
lpbmi^.bmiHeader.biHeight := nHeight;
lpbmi^.bmiHeader.biPlanes := 1;
lpbmi^.bmiHeader.biBitCount := nbpp;
lpbmi^.bmiHeader.biCompression := BI_RGB;
lpbmi^.bmiHeader.biSizeImage := 0;
lpbmi^.bmiHeader.biXPelsPerMeter := 0;
lpbmi^.bmiHeader.biYPelsPerMeter := 0;
lpbmi^.bmiHeader.biClrUsed := 0;
lpbmi^.bmiHeader.biClrImportant := 0; // Заполняем в таблице цветов
if CopyColorTable(lpbmi^, lpSrcDIB) then
begin
DC := GetDC(0);
hTargetBitmap := CreateDIBSection(DC, lpbmi^, DIB_RGB_COLORS,
lpTargetBits, 0, 0);
hSourceBitmap := CreateDIBSection(DC, lpSrcDIB, DIB_RGB_COLORS,
lpSourceBits, 0, 0);
try
if (dc <> 0) and (hTargetBitmap <> 0) and (hSourceBitmap <> 0) then
begin
hSourceDC := CreateCompatibleDC(DC);
hTargetDC := CreateCompatibleDC(DC);
try
if (hSourceDC <> 0) and (hTargetDC <> 0) then
begin
// Flip the bits on the source DIBSection to match the source DIB
dwSourceBitsSize := DWORD(lpSrcDIB.bmiHeader.biHeight) * BytesPerLine(lpSrcDIB.bmiHeader);
dwTargetBitsSize := DWORD(lpbmi^.bmiHeader.biHeight) *
BytesPerLine(lpbmi^.bmiHeader);
Move(FindDIBBits(lpSrcDIB)^, lpSourceBits^, dwSourceBitsSize);
// Select DIBSections into DCs
hOldSourceBitmap := SelectObject(hSourceDC, hSourceBitmap);
hOldTargetBitmap := SelectObject(hTargetDC, hTargetBitmap);
try
if (hOldSourceBitmap <> 0) and (hOldTargetBitmap <> 0) then
begin
// Устанавливаем таблицу цветов для DIBSections
if lpSrcDIB.bmiHeader.biBitCount <= 8 then
SetDIBColorTable(hSourceDC, 0, 1 shl lpSrcDIB.bmiHeader.biBitCount, lpSrcDIB.bmiColors);
if lpbmi^.bmiHeader.biBitCount <= 8 then
SetDIBColorTable(hTargetDC, 0, 1 shl
lpbmi^.bmiHeader.biBitCount, lpbmi^.bmiColors);
// If we are asking for a straight copy, do it
if (lpSrcDIB.bmiHeader.biWidth = lpbmi^.bmiHeader.biWidth) and (lpSrcDIB.bmiHeader.biHeight = lpbmi^.bmiHeader.biHeight) then
BitBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, SRCCOPY)
else if bStretch then
begin
SetStretchBltMode(hTargetDC, COLORONCOLOR);
StretchBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth,
lpbmi^.bmiHeader.biHeight,
hSourceDC, 0, 0, lpSrcDIB.bmiHeader.biWidth, lpSrcDIB.bmiHeader.biHeight,
SRCCOPY)
end
else
BitBlt(hTargetDC, 0, 0, lpbmi^.bmiHeader.biWidth, lpbmi^.bmiHeader.biHeight, hSourceDC, 0, 0, SRCCOPY);
GDIFlush;
GetMem(result, Integer(dwTargetHeaderSize + dwTargetBitsSize));
Move(lpbmi^, result^, dwTargetHeaderSize);
Move(lpTargetBits^, FindDIBBits(result^)^, dwTargetBitsSize)
end
finally
if hOldSourceBitmap <> 0 then SelectObject(hSourceDC, hOldSourceBitmap);
if hOldTargetBitmap <> 0 then SelectObject(hTargetDC, hOldTargetBitmap);
end
end
finally
if hSourceDC <> 0 then DeleteDC(hSourceDC);
if hTargetDC <> 0 then
DeleteDC(hTargetDC)
end
end;
finally
if hTargetBitmap <> 0 then DeleteObject(hTargetBitmap);
if hSourceBitmap <> 0 then DeleteObject(hSourceBitmap);
if dc <> 0 then
ReleaseDC(0, dc)
end
end
finally
FreeMem(lpbmi)
end
end;
function DIBToIconImage(var lpii: ICONIMAGE; var lpDIB: BitmapInfo;
bStretch: boolean): boolean;
var
lpNewDIB: PBitmapInfo;
begin
result := False;
lpNewDIB := ConvertDIBFormat(lpDIB, lpii.Width, lpii.Height, lpii.Colors,
bStretch);
if Assigned(lpNewDIB) then
try
lpii.dwNumBytes := sizeof(BITMAPINFOHEADER) // Заголовок
+ PaletteSize(lpNewDIB^.bmiHeader) // Палитра
+ lpii.Height * BytesPerLine(lpNewDIB^.bmiHeader) // XOR маска
+ lpii.Height * WIDTHBYTES(lpii.Width); // AND маска
// Если здесь уже картинка, то освобождаем е?
if lpii.lpBits <> nil then
FreeMem(lpii.lpBits);
GetMem(lpii.lpBits, lpii.dwNumBytes);
Move(lpNewDib^, lpii.lpBits^, sizeof(BITMAPINFOHEADER) + PaletteSize
(lpNewDIB^.bmiHeader));
// Выравниваем внутренние указатели/переменные для новой картинки
lpii.lpbi := PBITMAPINFOHEADER(lpii.lpBits);
lpii.lpbi^.biHeight := lpii.lpbi^.biHeight * 2;
lpii.lpXOR := FindDIBBits(PBitmapInfo(lpii.lpbi)^);
Move(FindDIBBits(lpNewDIB^)^, lpii.lpXOR^, lpii.Height * BytesPerLine
(lpNewDIB^.bmiHeader));
lpii.lpAND := lpii.lpXOR + lpii.Height * BytesPerLine
(lpNewDIB^.bmiHeader);
Fillchar(lpii.lpAnd^, lpii.Height * WIDTHBYTES(lpii.Width), $00);
result := True
finally
FreeMem(lpNewDIB)
end
end;
function TForm1.StringToIcon(const st: string): HIcon;
var
memDC: HDC;
bmp: HBITMAP;
oldObj: HGDIOBJ;
rect: TRect;
size: TSize;
infoHeaderSize: DWORD;
imageSize: DWORD;
infoHeader: PBitmapInfo;
icon: IconImage;
oldFont: HFONT;
begin
result := 0;
memDC := CreateCompatibleDC(0);
if memDC <> 0 then
try
bmp := CreateCompatibleBitmap(Canvas.Handle, 16, 16);
if bmp <> 0 then
try
oldObj := SelectObject(memDC, bmp);
if oldObj <> 0 then
try
rect.Left := 0;
rect.top := 0;
rect.Right := 16;
rect.Bottom := 16;
SetTextColor(memDC, RGB(255, 0, 0));
SetBkColor(memDC, RGB(128, 128, 128));
oldFont := SelectObject(memDC, font.Handle);
GetTextExtentPoint32(memDC, PChar(st), Length(st), size);
ExtTextOut(memDC, (rect.Right - size.cx) div 2, (rect.Bottom - size.cy) div 2, ETO_OPAQUE, @rect, PChar(st), Length(st), nil);
SelectObject(memDC, oldFont);
GDIFlush;
GetDibSizes(bmp, infoHeaderSize, imageSize);
GetMem(infoHeader, infoHeaderSize + ImageSize);
try
GetDib(bmp, SystemPalette16, infoHeader^, PChar(DWORD(infoHeader) + infoHeaderSize)^);
icon.Colors := 4;
icon.Width := 32;
icon.Height := 32;
icon.lpBits := nil;
if DibToIconImage(icon, infoHeader^, True) then
try
result := CreateIconFromResource(PByte(icon.lpBits), icon.dwNumBytes, True, $00030000);
finally
FreeMem(icon.lpBits)
end
finally
FreeMem(infoHeader)
end
finally
SelectObject(memDC, oldOBJ)
end
finally
DeleteObject(bmp)
end
finally
DeleteDC(memDC)
end
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Application.Icon.Handle := StringToIcon('0');
Timer1.Enabled := True;
Button1.Enabled := False;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Inc(sss);
if sss > 100 then sss := 1;
Application.Icon.Handle := StringToIcon(IntToStr(sss));
end;
end.
Автор ответа: Baa
Взято с Vingrad.ru
Как преобразовать указатель на метод в указатель на функцию?
Как преобразовать указатель на метод в указатель на функцию?
// Converting method pointers into function pointers
// Often you need a function pointer for a callback function. But what, if you want to specify a method as
// an callback? Converting a method pointer to a function pointer is not a trivial task; both types are
// incomatible with each other. Although you have the possibility to convert like this "@TClass.SomeMethod",
// this is more a hack than a solution, because it restricts the use of this method to some kind of a class
// function, where you cannot access instance variables. If you fail to do so, you'll get a wonderful gpf.
// But there is a better solution: run time code generation! Just allocate an executeable memory block, and
// write 4 machine code instructions into it: 2 instructions loads the two pointers of the method pointer
// (code & data) into the registers, one calls the method via the code pointer, and the last is just a return
// Now you can use this pointer to the allocated memory as a plain funtion pointer, but in fact you are
// calling a method for a specific instance of a Class.
type TMyMethod = procedure of object;
function MakeProcInstance(M: TMethod): Pointer;
begin
// allocate memory
GetMem(Result, 15);
asm
// MOV ECX,
MOV BYTE PTR [EAX], $B9
MOV ECX, M.Data
MOV DWORD PTR [EAX+$1], ECX
// POP EDX
MOV BYTE PTR [EAX+$5], $5A
// PUSH ECX
MOV BYTE PTR [EAX+$6], $51
// PUSH EDX
MOV BYTE PTR [EAX+$7], $52
// MOV ECX,
MOV BYTE PTR [EAX+$8], $B9
MOV ECX, M.Code
MOV DWORD PTR [EAX+$9], ECX
// JMP ECX
MOV BYTE PTR [EAX+$D], $FF
MOV BYTE PTR [EAX+$E], $E1
end;
end;
procedure FreeProcInstance(ProcInstance: Pointer);
begin
// free memory
FreeMem(ProcInstance, 15);
end;
Взято с сайта
Как прервать печать и заставить печатать свой файл?
Как прервать печать и заставить печатать свой файл?
uses
printers;
{$R *.DFM}
procedure StartPrintToFile(filename: string);
var
CTitle: array[0..31] of Char;
DocInfo: TDocInfo;
begin
with Printer do
begin
BeginDoc;
{ Abort job just started on API level. }
EndPage(Canvas.handle);
Windows.AbortDoc(Canvas.handle);
{ Restart it with a print file as destination. }
StrPLCopy(CTitle, Title, SizeOf(CTitle) - 1);
FillChar(DocInfo, SizeOf(DocInfo), 0);
with DocInfo do
begin
cbSize := SizeOf(DocInfo);
lpszDocName := CTitle;
lpszOutput := PChar(filename);
end;
StartDoc(Canvas.handle, DocInfo);
StartPage(Canvas.handle);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
StartPrintToFile('C:\temp\temp.prn');
try
Printer.Canvas.TextOut(100, 100, 'Hello World.');
finally
Printer.endDoc;
end;
end;
Взято с
Delphi Knowledge BaseКак при выполнении долгой операции в Oracle показать прогресс бар?
Как при выполнении долгой операции в Oracle показать прогресс бар?
Автор: Philip A. Milovanov ( http://korys.chat.ru )
Ниже приведен пример, как это сделать при помощи Direct Oracle Access, надеюсь этот кусок кода несложно запустить в отдельном процессе, а в другом можно запустить перемесчатель прогресс бара. Есть готовая компонента, могу поделиться.
//на создании потока вставим то, что будет выбирать необходимую информацию
Self.fods.SQL.Text:='SELECT SOFAR FROM V$SESSION_LONGOPS WHERE CONTEXT=:FK_ID';
Self.fods.DeclareVariable('FK_ID',otInteger);
Self.fods.SetVariable('FK_ID',ID);
//На выполнение потока вешаем открытие/закрытие TOracleDataSet
while (Terminated = false) do
begin
Self.fods.Close;
Self.fods.Open;
Self.fpb.Progress := Self.fods.FieldByName('SOFAR').AsInteger;
//^^^^Эта строчка как раз и устанавливает нужный прогрессбар в нужную позицию...
end;
Ну и соответсвенно перед выполнением всего этого дела необходимо выставить максимальное число (100%) :
PROCEDURE SETMaxValue(nVal IN NUMBER);
Минимальное:
PROCEDURE SETMinValue(nVal IN NUMBER);
Значение шага:
PROCEDURE SetStepValue(nValue IN NUMBER);
Вышеприведенный кусок кода - клиентская часть, но есть и "подводный камень" - серверная часть... Данный метотод подкодит только для функций, процедур и пактеов, в которых вы можете написать вставить следущую строчку:
PROGRESS_BAR.STEPIT;
Код пакета PROGRESS_BAR приведен ниже:
create or replace package PROGRESS_BAR
IS
-- Wrote by Philip A. Milovanov
nMaxValue NUMBER:=0;
nMinValue NUMBER:=0;
nCurrentValue NUMBER:=0;
nStepValue NUMBER:=1;
nID PLS_INTEGER;
slno PLS_INTEGER;
target PLS_INTEGER;
PROCEDURE SETMaxValue(nVal IN NUMBER);
PROCEDURE SETMinValue(nVal IN NUMBER);
FUNCTION INIT RETURN NUMBER;
PROCEDURE StepIt;
PROCEDURE SetStepValue(nValue IN NUMBER);
PROCEDURE StepIt(C IN NUMBER);
END; -- Package Specification PROGRESS_BAR
/
--Сам пакет:
Create or Replace Package Body PROGRESS_BAR
IS
-- Wrote by Philip A. Milovanov
PROCEDURE SETMaxValue(nVal IN NUMBER) IS
BEGIN
if nVal<nMinValue THEN
RAISE_APPLICATION_ERROR(-20001,'Ìèíèìàëüíîå çíà÷åíèå íå äîëæíî áûòü áîëüøå ìàêñèìàëüíîãî ìèí:'nMinValue' ,ìàêñ:'nVal);
END IF;
nMaxValue:=nVal;
END;
PROCEDURE SETMinValue(nVal IN NUMBER) IS
BEGIN
if nVal>nMaxValue THEN
RAISE_APPLICATION_ERROR(-20001,'Ìèíèìàëüíîå çíà÷åíèå íå äîëæíî áûòü áîëüøå ìàêñèìàëüíîãî ìèí:'nVal' ,ìàêñ:'nMaxValue);
END IF;
nMinValue:=nVal;
END;
FUNCTION INIT RETURN NUMBER IS
CURSOR c IS SELECT OBJECT_ID FROM ALL_OBJECTS WHERE OBJECT_NAME='PROGRESS_BAR';
i NUMBER;
BEGIN
OPEN c;
FETCH c INTO target;
CLOSE c;
SELECT SEQ_TPROCESS_BAR.NEXTVAL INTO i FROM DUAL;
nCurrentValue:=nMinValue;
nID:=DBMS_APPLICATION_INFO.set_session_longops_nohint;
DBMS_APPLICATION_INFO.SET_SESSION_LONGOPS(nID,slno,'CALCULATING REPORT',target,i,nCurrentValue,nMaxValue,'PROGRESS BAR INFO',NULL);
RETURN i;
END;
PROCEDURE StepIt IS
BEGIN
nCurrentValue:=nCurrentValue+nStepValue;
DBMS_APPLICATION_INFO.SET_SESSION_LONGOPS(nID,slno,'CALCULATING REPORT',target,nMinValue,nCurrentValue,nMaxValue,'PROGRESS BAR INFO',NULL);
END;
PROCEDURE SetStepValue(nValue IN NUMBER) IS
BEGIN
nStepValue:=nValue;
END;
PROCEDURE StepIt(C IN NUMBER) IS
BEGIN
nCurrentValue:=nCurrentValue+c;
DBMS_APPLICATION_INFO.SET_SESSION_LONGOPS(nID,slno,'CALCULATING REPORT',target,nMinValue,nCurrentValue,nMaxValue,'PROGRESS BAR INFO',NULL);
END;
END;
Взято с Исходников.ru
Как прикрепить свою форму к другому приложению?
Как прикрепить свою форму к другому приложению?
Для этого Вам понадобится переопределить процедуру CreateParams у желаемой формы. А в ней установить params.WndParent в дескриптор окна, к которому Вы хотите прикрепить форму.
... = class(TForm)
...
protected
procedure CreateParams( var params: TCreateParams ); override;
...
procedure TForm2.Createparams(var params: TCreateParams);
var
aHWnd : HWND;
begin
inherited;
{как-нибудь получаем существующий дескриптор}
ahWnd := GetForegroundWindow;
{а теперь:}
params.WndParent := ahWnd;
end;
Взято с Исходников.ru
Как приложение оставить свёрнутым в иконку?
Как приложение оставить свёрнутым в иконку?
Для этого необходимо обработать сообщение WMQUERYOPEN. Однако обработчик сообщения необходимо поместить в секции private - т.е. в объявлении TForm.
procedure WMQueryOpen(var Msg: TWMQueryOpen); message WM_QUERYOPEN;
Реализация будет выглядеть следующим образом:
procedure WMQueryOpen(var Msg: TWMQueryOpen);
begin
Msg.Result := 0;
end;
Как приложению воспользоваться своими шрифтами?
Как приложению воспользоваться своими шрифтами?
Может ли кто-нибудь подсказать или решить такую проблему: мне нужно убедиться, что мое приложение использует доступные, а не ближайшие шрифты, установленные пользователем в системе? Я пробовал копировать файл #.ttf в директорию пользователя windows\system, но мое приложение так и не смогло их увидеть и выбрать для дальнейшего использования.
Ниже приведен код для Delphi, который динамически устанавливает шрифты, загружаемые только во время работы приложения. Вы можете расположить файл(ы) шрифтов в каталоге приложения. Они будут инсталлированы при загрузке формы и выгружены при ее разрушении. Вам возможно придется модифицировать код для работы с Delphi 2, поскольку он использует вызовы Windows API, которые могут как измениться, так и нет. Если в коде вы видите "...", то значит в этом месте может располагаться какой-либо код, не относящийся к существу вопроса.
Ну и, конечно, вы должны заменить "MYFONT" на реальное имя файла вашего шрифта.
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
...
private
{ Private declarations }
bLoadedFont: boolean;
public
{ Public declarations }
end;
procedure TForm1.FormCreate(Sender: TObject);
var
sAppDir: string;
sFontRes: string;
begin
sAppDir := Application.ExeName;
sAppDir := copy(sAppDir, 1, rpos('\', sAppDir));
sFontRes := sAppDir + 'MYFONT.FOT';
if not FileExists(sFontRes) then
begin
sFontRes := sFontRes + #0;
sFont := sAppDir + 'MYFONT.TTF' + #0;
CreateScalableFontResource(0, @sFontRes[1], @sFont[1], nil);
end;
sFontRes := sAppDir + 'MYFONT.FOT';
if FileExists(sFontRes) then
begin
sFontRes := sFontRes + #0;
if AddFontResource(@sFontRes[1]) = 0 then
bLoadedFont := false
else
begin
bLoadedFont := true;
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;
end;
...
end;
procedure TForm1.FormDestroy(Sender: TObject);
var
sFontRes: string;
begin
if bLoadedFont then
begin
sFontRes := sAppDir + 'MYFONT.FOT' + #0;
RemoveFontResource(@sFontRes[1]);
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;
end;
Я поработал с данным кодом и внес некоторые поправки для корректной работы на Delphi 2.0. На Delphi 3.0 не испытано.
Электронная справка по продукту InstallShield показывает, что в системах Win95 и WinNT FOT-файл не нужен. Вам нужен только TTF-файл.
В результате процедура FormCreate стала выглядеть так:
var
sAppDir, sFontRes: string;
begin
{...другой код...}
sAppDir := extractfilepath(Application.ExeName);
sFontRes := sAppDir + 'MYFONT.TTF';
if FileExists(sFontRes) then
begin
sFontRes := sFontRes + #0;
if AddFontResource(@sFontRes[1]) = 0 then
bLoadedFont := false
else
begin
bLoadedFont := true;
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;
end;
{...}
end; {FormCreate}
А FormDestroy так:
var
sFontRes, sAppDir: string;
begin
{...другой код...}
if bLoadedFont then
begin
sAppDir := extractfilepath(Application.ExeName);
sFontRes := sAppDir + 'MYFONT.TTF' + #0;
RemoveFontResource(@sFontRes[1]);
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;
{...другой код...}
end; {FormDestroy}
Для упрощения этого я сделал простую функцию, совмещающую обе этих задачи. Она возвращает логическое значение, говорящая об успехе, или наоборот, о неудаче операции загрузки или выгрузки шрифта.
{1998-01-16 Функция загрузки и выгрузки шрифта.}
function LoadFont(sFontFileName: string; bLoadIt: boolean): boolean;
var
sFont, sAppDir, sFontRes: string;
begin
result := TRUE;
if bLoadIt then
begin
{Загрузка шрифта.}
if FileExists(sFontFileName) then
begin
sFontRes := sFontFileName + #0;
if AddFontResource(@sFontRes[1]) = 0 then
result := FALSE
else
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;
end
else
begin
{Выгрузка шрифта.}
sFontRes := sFontFileName + #0;
result := RemoveFontResource(@sFontRes[1]);
SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0);
end;
end; {LoadFont}
Взято из
Как принимать перетаскиваемые файлы из проводника?
Как принимать перетаскиваемые файлы из проводника?
Вот пример с TListbox на форме:
type
TForm1 = class(TForm)
ListBox1: TListBox;
procedure FormCreate(Sender: TObject);
protected
procedure WMDROPFILES (var Msg: TMessage); message WM_DROPFILES;
private
public
end;
var
Form1: TForm1;
implementation
uses shellapi;
{$R *.DFM}
procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles(Form1.Handle, true);
end;
procedure TForm1.WMDROPFILES (var Msg: TMessage);
var
i,
amount,
size: integer;
Filename: PChar;
begin
inherited;
Amount := DragQueryFile(Msg.WParam, $FFFFFFFF, Filename, 255);
for i := 0 to (Amount - 1) do
begin
size := DragQueryFile(Msg.WParam, i , nil, 0) + 1;
Filename:= StrAlloc(size);
DragQueryFile(Msg.WParam,i , Filename, size);
listbox1.items.add(StrPas(Filename));
StrDispose(Filename);
end;
DragFinish(Msg.WParam);
end;
Взято с Исходников.ru
Как присвоить событие в run-time?
Как присвоить событие в run-time?
Пример стандартного присвоения события в run-time:
type
TForm1 = class(TForm)
Button1: TButton;
procedure FormCreate(Sender: TObject);
private
procedure Click(Sender: TObject);
end;
var Form1: TForm1;
implementation
procedure TForm1.Click(Sender: TObject);
begin
// do something
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
button1.OnClick:=Click;
end;
end.
Автор ответа: Vit
Взято с Vingrad.ru
А как сделать чтобы "procedure Click" была не методом класса, а отдельно стоящей функцией?
procedure Click(Self: TObject; Sender: TObject);
begin
...
end;
var
evhandler: TNotifyEvent;
TMethod(evhandler).Code := @Click;
TMethod(evhandler).Data := nil;
Button1.OnClick := evhandler;
Без извращений можно так:
TDummy = class
class procedure Click(Sender: TObject);
end;
Button1.OnClick := TDummy.Click;
Автор ответа: Le Taon
Взято с Vingrad.ru
По идее, при вызове OnClick первым параметром будет запихнут указатель на экземпляр того класса который в этом OnClick хранится . Я в низкоуровневой реализации не силен, но кажись, так как параметры в процедурах в Delphi передаются через регистры, то ничего страшного не произойдет.
procedure C(Self:pointer;Sender:TObject);
begin
TButton(Sender).Caption:='ee';
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
@Button1.OnClick:=@c;
end;
Self тут у нас будет равен nil, а Sender как раз и получается Sender'ом.
Автор ответа: Fantasist
Взято с Vingrad.ru
Как присвоить все значения полей одного класса, другому такому же классу?
Как присвоить все значения полей одного класса, другому такому же классу?
How can I assign all property values (or if it's not possible only published property values, or some of them) of one class (TComponent) to another instance of the same class? What I want to do is:
MyComponent1.{property1}:= MyComponent2.{property1};
{...}
MyComponent2.{propertyN} := MyComponent2.{propertyN};
Is there a better and shorter way to do this? I tried this: MyComponent1 := MyComponent2; But it doesn't work. Why not? Can I point to the second component ?
Answer 1:
MyComponent2 and MyComponent1 are pointers to your components, and this kind of assigment leads to MyComponent1 pointing to MyComponent2. But it will not copy its property values.
A better way is to override the assign method of your control, do all property assignment there and call it when you need to copy component attributes. Here's example:
procedure TMyComponent.Assign(Source: TPersistent);
begin
if Source is TMyComponent then
begin
property1 := TMyComponent(Source).property1;
{ ... }
end
else
inherited Assign(Source);
end;
To assign properties you'll need to set this line in the code:
MyComponent1.Assign(MyComponent2);
Tip by Serge Gubenko
procedure EqualClassProperties(AClass1, AClass2: TObject);
var
PropList: PPropList;
ClassTypeInfo: PTypeInfo;
ClassTypeData: PTypeData;
i: integer;
NumProps: Integer;
APersistent : TPersistent;
begin
if AClass1.ClassInfo <> AClass2.ClassInfo then
exit;
ClassTypeInfo := AClass1.ClassInfo;
ClassTypeData := GetTypeData(ClassTypeInfo);
if ClassTypeData.PropCount <> 0 then
begin
GetMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
try
GetPropInfos(AClass1.ClassInfo, PropList);
for i := 0 to ClassTypeData.PropCount - 1 do
if not (PropList[i]^.PropType^.Kind = tkMethod) then
{if Class1,2 is TControl/TWinControl on same form, its names must be unique}
if PropList[i]^.Name <> 'Name' then
if (PropList[i]^.PropType^.Kind = tkClass) then
begin
APersistent := TPersistent(GetObjectProp(AClass1, PropList[i]^.Name, TPersistent));
if APersistent <> nil then
APersistent.Assign(TPersistent(GetObjectProp(AClass2, PropList[i]^.Name, TPersistent)))
end
else
SetPropValue(AClass1, PropList[i]^.Name, GetPropValue(AClass2, PropList[i]^.Name));
finally
FreeMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
end;
end;
end;
Note that this code skips object properties inherited other than TPersistent.
Tip by Gokhan Ersumer
Взято из
Как присвоить значение свойству selected в ListBox?
Как присвоить значение свойству selected в ListBox?
Свойство "selected" компонента ТListBox может быть использованно только если свойство MultiSelect установленно в True. Если Вы работаете с ListBox'ом у которого MultiSelect=false то используйте свойство ItemIndex.
procedure TForm1.Button1Click(Sender: TObject);
begin
ListBox1.Items.Add('1');
ListBox1.Items.Add('2');
{This will fail on a single selection ListBox}
// ListBox1.Selected[1] := true;
ListBox1.ItemIndex := 1; {This is ok}
end;
Взято с Исходников.ru
Как прочитать адресную книгу Outlook (MSOffice) из Delphi и занести данные в таблицу *.db?
Как прочитать адресную книгу Outlook (MSOffice) из Delphi и занести данные в таблицу *.db?
Сперва сделай 'Import type Library' для Outlk80.olb, (расположен в \Program Files\Microsoft Office\Office).
После того, как появится файл 'Outlook_TLB.pas', можно нацарапать следующее:
uses ComObj, Outlook_TLB;procedure TForm1.Button1Click(Sender: TObject);var MSOutlook, MyNameSpace,
MyFolder, MyItem: Variant; s: string; i: Integer;begin try MSOutlook := CreateOleObject('Outlook.Application');
MyNameSpace := MSOutlook.GetNameSpace('MAPI'); MyFolder := MyNamespace.GetDefaultFolder(olFolderContacts);
for i := 1 to MyFolder.Items.Count do
begin
s := s + #13#13'Contact No: ' + IntToStr(i) + #13#13;
MyItem := MyFolder.Items[i];
s := s + 'BillingInformation: ' + MyItem.BillingInformation + #13;
s := s + 'Body: ' + MyItem.Body + #13; s := s + 'Categories: ' + MyItem.Categories + #13;
s := s + 'Companies: ' + MyItem.Companies + #13; s := s + 'CreationTime: ' + DateTimeToStr(MyItem.CreationTime) + #13;
s := s + 'EntryID: ' + MyItem.EntryID + #13; s := s + 'Importance: ' + IntToStr(MyItem.Importance) + #13;
s := s + 'LastModificationTime: ' + DateTimeToStr(MyItem.LastModificationTime) + #13;
s := s + 'MessageClass: ' + MyItem.MessageClass + #13; s := s + 'Mileage: ' + MyItem.Mileage + #13;
s := s + 'NoAging: ' + IntToStr(MyItem.NoAging) + #13; s := s + 'OutlookVersion: ' + MyItem.OutlookVersion + #13;
s := s + 'Saved: ' + IntToStr(MyItem.Saved) + #13; s := s + 'Sensitivity: ' + IntToStr(MyItem.Sensitivity) + #13;
s := s + 'Size: ' + IntToStr(MyItem.Size) + #13; s := s + 'Subject: ' + MyItem.Subject + #13;
s := s + 'UnRead: ' + IntToStr(MyItem.UnRead) + #13; s := s + 'Account: ' + MyItem.Account + #13;
s := s + 'Anniversary: ' + DateTimeToStr(MyItem.Anniversary) + #13;
s := s + 'AssistantName: ' + MyItem.AssistantName + #13;
s := s + 'AssistantTelephoneNumber: ' + MyItem.AssistantTelephoneNumber + #13;
s := s + 'Birthday: ' + DateTimeToStr(MyItem.Birthday) + #13;
s := s + 'Business2TelephoneNumber: ' + MyItem.Business2TelephoneNumber + #13;
s := s + 'BusinessAddress: ' + MyItem.BusinessAddress + #13;
s := s + 'BusinessAddressCity: ' + MyItem.BusinessAddressCity + #13;
s := s + 'BusinessAddressCountry: ' + MyItem.BusinessAddressCountry + #13;
s := s + 'BusinessAddressPostalCode: ' + MyItem.BusinessAddressPostalCode + #13;
s := s + 'BusinessAddressPostOfficeBox: ' + MyItem.BusinessAddressPostOfficeBox + #13;
s := s + 'BusinessAddressState: ' + MyItem.BusinessAddressState + #13;
s := s + 'BusinessAddressStreet: ' + MyItem.BusinessAddressStreet + #13;
s := s + 'BusinessFaxNumber: ' + MyItem.BusinessFaxNumber + #13;
s := s + 'BusinessHomePage: ' + MyItem.BusinessHomePage + #13;
s := s + 'BusinessTelephoneNumber: ' + MyItem.BusinessTelephoneNumber + #13;
s := s + 'CallbackTelephoneNumber: ' + MyItem.CallbackTelephoneNumber + #13;
s := s + 'CarTelephoneNumber: ' + MyItem.CarTelephoneNumber + #13;
s := s + 'Children: ' + MyItem.Children + #13;
s := s + 'CompanyAndFullName: ' + MyItem.CompanyAndFullName + #13;
s := s + 'CompanyMainTelephoneNumber: ' + MyItem.CompanyMainTelephoneNumber + #13;
s := s + 'CompanyName: ' + MyItem.CompanyName + #13;
s := s + 'ComputerNetworkName: ' + MyItem.ComputerNetworkName + #13;
s := s + 'CustomerID: ' + MyItem.CustomerID + #13;
s := s + 'Department: ' + MyItem.Department + #13;
s := s + 'Email1Address: ' + MyItem.Email1Address + #13;
s := s + 'Email1AddressType: ' + MyItem.Email1AddressType + #13;
s := s + 'Email1DisplayName: ' + MyItem.Email1DisplayName + #13;
s := s + 'Email1EntryID: ' + MyItem.Email1EntryID + #13;
s := s + 'Email2Address: ' + MyItem.Email2Address + #13;
s := s + 'Email2AddressType: ' + MyItem.Email2AddressType + #13;
s := s + 'Email2DisplayName: ' + MyItem.Email2DisplayName + #13;
s := s + 'Email2EntryID: ' + MyItem.Email2EntryID + #13;
s := s + 'Email3Address: ' + MyItem.Email3Address + #13;
s := s + 'Email3AddressType: ' + MyItem.Email3AddressType + #13;
s := s + 'Email3DisplayName: ' + MyItem.Email3DisplayName + #13;
s := s + 'Email3EntryID: ' + MyItem.Email3EntryID + #13;
s := s + 'FileAs: ' + MyItem.FileAs + #13;
s := s + 'FirstName: ' + MyItem.FirstName + #13;
s := s + 'FTPSite: ' + MyItem.FTPSite + #13;
s := s + 'FullName: ' + MyItem.FullName + #13;
s := s + 'FullNameAndCompany: ' + MyItem.FullNameAndCompany + #13;
s := s + 'Gender: ' + IntToStr(MyItem.Gender) + #13;
s := s + 'GovernmentIDNumber: ' + MyItem.GovernmentIDNumber + #13;
s := s + 'Hobby: ' + MyItem.Hobby + #13;
s := s + 'Home2TelephoneNumber: ' + MyItem.Home2TelephoneNumber + #13;
s := s + 'HomeAddress: ' + MyItem.HomeAddress + #13;
s := s + 'HomeAddressCity: ' + MyItem.HomeAddressCity + #13;
s := s + 'HomeAddressCountry: ' + MyItem.HomeAddressCountry + #13;
s := s + 'HomeAddressPostalCode: ' + MyItem.HomeAddressPostalCode + #13;
s := s + 'HomeAddressPostOfficeBox: ' + MyItem.HomeAddressPostOfficeBox + #13;
s := s + 'HomeAddressState: ' + MyItem.HomeAddressState + #13;
s := s + 'HomeAddressStreet: ' + MyItem.HomeAddressStreet + #13;
s := s + 'HomeFaxNumber: ' + MyItem.HomeFaxNumber + #13;
s := s + 'HomeTelephoneNumber: ' + MyItem.HomeTelephoneNumber + #13;
s := s + 'Initials: ' + MyItem.Initials + #13;
s := s + 'ISDNNumber: ' + MyItem.ISDNNumber + #13;
s := s + 'JobTitle: ' + MyItem.JobTitle + #13;
s := s + 'Journal: ' + IntToStr(MyItem.Journal) + #13;
s := s + 'Language: ' + MyItem.Language + #13;
s := s + 'LastName: ' + MyItem.LastName + #13;
s := s + 'LastNameAndFirstName: ' + MyItem.LastNameAndFirstName + #13;
s := s + 'MailingAddress: ' + MyItem.MailingAddress + #13;
s := s + 'MailingAddressCity: ' + MyItem.MailingAddressCity + #13;
s := s + 'MailingAddressCountry: ' + MyItem.MailingAddressCountry + #13;
s := s + 'MailingAddressPostalCode: ' + MyItem.MailingAddressPostalCode + #13;
s := s + 'MailingAddressPostOfficeBox: ' + MyItem.MailingAddressPostOfficeBox + #13;
s := s + 'MailingAddressState: ' + MyItem.MailingAddressState + #13;
s := s + 'MailingAddressStreet: ' + MyItem.MailingAddressStreet + #13;
s := s + 'ManagerName: ' + MyItem.ManagerName + #13;
s := s + 'MiddleName: ' + MyItem.MiddleName + #13;
s := s + 'MobileTelephoneNumber: ' + MyItem.MobileTelephoneNumber + #13;
s := s + 'NickName: ' + MyItem.NickName + #13;
s := s + 'OfficeLocation: ' + MyItem.OfficeLocation + #13;
s := s + 'OrganizationalIDNumber: ' + MyItem.OrganizationalIDNumber + #13;
s := s + 'OtherAddress: ' + MyItem.OtherAddress + #13;
s := s + 'OtherAddressCity: ' + MyItem.OtherAddressCity + #13;
s := s + 'OtherAddressCountry: ' + MyItem.OtherAddressCountry + #13;
s := s + 'OtherAddressPostalCode: ' + MyItem.OtherAddressPostalCode + #13;
s := s + 'OtherAddressPostOfficeBox: ' + MyItem.OtherAddressPostOfficeBox + #13;
s := s + 'OtherAddressState: ' + MyItem.OtherAddressState + #13;
s := s + 'OtherAddressStreet: ' + MyItem.OtherAddressStreet + #13;
s := s + 'OtherFaxNumber: ' + MyItem.OtherFaxNumber + #13;
s := s + 'OtherTelephoneNumber: ' + MyItem.OtherTelephoneNumber + #13;
s := s + 'PagerNumber: ' + MyItem.PagerNumber + #13;
s := s + 'PersonalHomePage: ' + MyItem.PersonalHomePage + #13;
s := s + 'PrimaryTelephoneNumber: ' + MyItem.PrimaryTelephoneNumber + #13;
s := s + 'Profession: ' + MyItem.Profession + #13;
s := s + 'RadioTelephoneNumber: ' + MyItem.RadioTelephoneNumber + #13;
s := s + 'ReferredBy: ' + MyItem.ReferredBy + #13;
s := s + 'SelectedMailingAddress: ' + In s := s + 'Spouse: ' + MyItem.Spouse + #13; s := s + 'Suffix: ' + MyItem.Suffix + #13;
s := s + 'TelexNumber: ' + MyItem.TelexNumber + #13; s := s + 'Title: ' + MyItem.Title + #13;
s := s + 'TTYTDDTelephoneNumber: ' + MyItem.TTYTDDTelephoneNumber + #13;
s := s + 'User1: ' + MyItem.User1 + #13; s := s + 'User2: ' + MyItem.User2 + #13;
s := s + 'User3: ' + MyItem.User3 + #13; s := s + 'User4: ' + MyItem.User4 + #13;
s := s + 'UserCertificate: ' + MyItem.UserCertificate + #13;
s := s + 'WebPage: ' + MyItem.WebPage + #13;
end;
Memo1.Lines.Text := s; except on
E: Exception do MessageDlg(E.Message + #13 + s, mtError, [mbOk], 0)
end; MSOutlook.Quit;
end;
Взято с сайта
Как прочитать байт из параллельного порта?
Как прочитать байт из параллельного порта?
Первый способ:
Var
BytesRead : BYTE;
begin
asm \{ Читаем порт (LPT1) через встроенный ассемблер \}
MOV dx,$379;
IN al,dx;
MOV BytesRead,al;
end;
BytesRead:=(BytesRead OR $07); \{ OR а затем XOR данных \}
BytesRead:=(BytesRead XOR $80); \{ маскируем неиспользуемые биты \}
Второй способ :
Используем команды Turbo Pascal ...
value:=port[$379]; \{ Прочитать из порта \}
port[$379]:=value; \{ Записать в порт \}
Взято с Исходников.ru
Как прочитать из модема?
Как прочитать из модема?
После предварительной настройки переменных, COM порт открывается как обычный файл. Так же пример показывает, как очищать буфер COM порта и читать из него.
Var
PortSpec : array[0..255] of char;
PortNo : Word;
success : Boolean;
error:integer;
begin
FillChar(PortSpec,Sizeof(PortSpec),#0);
StrPCopy(PortSpec,'Com1:19200,n,8,1');
PortSpec[3]:=Char(Ord(PortSpec[3])+Ord(PortNo));
if not BuildCommDCB(PortSpec,Mode) Then
Begin
//какая-то ошибка...
Exit;
End;
PortSpec[5]:=#0; { 'Com1:' }
Mode.Flags:=EV_RXCHAR + EV_EVENT2; { $1001 }
Com := CreateFile(PortSpec,GENERIC_READ or GENERIC_WRITE,
0, //* comm устройство открывается с эксклюзивным доступом*/
Nil, //* нет security битов */
OPEN_EXISTING, //* comm устройства должны использовать OPEN_EXISTING*/
0, //* not overlapped I/O */
0 //* hTemplate должен быть NULL для comm устройств */
);
if Com = INVALID_HANDLE_VALUE then Error := GetLastError;
Success := GetCommState(Com,Mode);
if not Success then // Обработчик ошибки.
begin
end;
Mode.BaudRate := 19200;
Mode.ByteSize := 8;
Mode.Parity := NOPARITY;
Mode.StopBits := ONESTOPBIT;//нужен был для перезаписи в NT
Success := SetCommState(Com, Mode);
if not Success then // Обработчик ошибки.
begin
end;
end;
Переменная "com" типа dword.
Вы так же можете очистить буффер COM порта
PurgeComm(Com,PURGE_RXCLEAR or PURGE_TXCLEAR);
И прочитать из него
Function ReadCh(Var Ch:Byte):dword;
var
n : dword;
Begin
Readfile(Com,ch,1,result,nil);
End;
Взято с Исходников.ru
Как прочитать/изменить startpage IE?
Как прочитать/изменить startpage IE?
uses
{...,}Registry;
function GetIEStartPage: string;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
Reg.OpenKey('Software\Microsoft\Internet Explorer\Main', False);
try
Result := Reg.ReadString('Start Page');
except
Result := '';
end;
Reg.CloseKey;
finally
Reg.Free;
end;
end;
function SetIEStartPage(APage: string): Boolean;
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
Reg.RootKey := HKEY_CURRENT_USER;
Reg.OpenKey('Software\Microsoft\Internet Explorer\Main', False);
try
Reg.WriteString('Start Page', APage);
Result := True;
finally
Reg.CloseKey;
Result := False;
end;
finally
Reg.Free;
end;
end;
// Show the Startpage
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetIEStartPage);
end;
// Set the Startpage
procedure TForm1.Button2Click(Sender: TObject);
begin
SetIEStartPage('http://forum.vingrad.ru');
end;
Взято с сайта
Как прочитать/изменить свойства Word документа?
Как прочитать/изменить свойства Word документа?
{ 1. Change MS Word properties via OLE }
uses
ComObj;
procedure TForm1.Button1Click(Sender: TObject);
const
wdPropertyTitle = $00000001;
wdPropertySubject = $00000002;
wdPropertyAuthor = $00000003;
wdPropertyKeywords = $00000004;
wdPropertyComments = $00000005;
wdPropertyTemplate = $00000006;
wdPropertyLastAuthor = $00000007;
wdPropertyRevision = $00000008;
wdPropertyAppName = $00000009;
wdPropertyTimeLastPrinted = $0000000A;
wdPropertyTimeCreated = $0000000B;
wdPropertyTimeLastSaved = $0000000C;
wdPropertyVBATotalEdit = $0000000D;
wdPropertyPages = $0000000E;
wdPropertyWords = $0000000F;
wdPropertyCharacters = $00000010;
wdPropertySecurity = $00000011;
wdPropertyCategory = $00000012;
wdPropertyFormat = $00000013;
wdPropertyManager = $00000014;
wdPropertyCompany = $00000015;
wdPropertyBytes = $00000016;
wdPropertyLines = $00000017;
wdPropertyParas = $00000018;
wdPropertySlides = $00000019;
wdPropertyNotes = $0000001A;
wdPropertyHiddenSlides = $0000001B;
wdPropertyMMClips = $0000001C;
wdPropertyHyperlinkBase = $0000001D;
wdPropertyCharsWSpaces = $0000001E;
const
AWordDoc = 'C:\Test.doc';
wdSaveChanges = $FFFFFFFF;
var
WordApp: OLEVariant;
SaveChanges: OleVariant;
begin
try
WordApp := CreateOleObject('Word.Application');
except
// Error....
Exit;
end;
try
WordApp.Visible := False;
WordApp.Documents.Open(AWordDoc);
WordApp.ActiveDocument.BuiltInDocumentProperties[wdPropertyTitle].Value := 'Your Title...';
WordApp.ActiveDocument.BuiltInDocumentProperties[wdPropertySubject].Value := 'Your Subject...';
// ...
// ...
finally
SaveChanges := wdSaveChanges;
WordApp.Quit(SaveChanges, EmptyParam, EmptyParam);
end;
end;
{**********************************************}
{
2. Read MS Word properties via Structured Storage.
by Serhiy Perevoznyk
}
uses
ComObj, ActiveX;
const
FmtID_SummaryInformation: TGUID =
'{F29F85E0-4FF9-1068-AB91-08002B27B3D9}';
function FileTimeToDateTimeStr(F: TFileTime): string;
var
LocalFileTime: TFileTime;
SystemTime: TSystemTime;
DateTime: TDateTime;
begin
if Comp(F) = 0 then Result := '-'
else
begin
FileTimeToLocalFileTime(F, LocalFileTime);
FileTimeToSystemTime(LocalFileTime, SystemTime);
with SystemTime do
DateTime := EncodeDate(wYear, wMonth, wDay) +
EncodeTime(wHour, wMinute, wSecond, wMilliseconds);
Result := DateTimeToStr(DateTime);
end;
end;
function GetDocInfo(const FileName: WideString): string;
var
I: Integer;
PropSetStg: IPropertySetStorage;
PropSpec: array[2..19] of TPropSpec;
PropStg: IPropertyStorage;
PropVariant: array[2..19] of TPropVariant;
Rslt: HResult;
S: string;
Stg: IStorage;
begin
Result := '';
try
OleCheck(StgOpenStorage(PWideChar(FileName), nil, STGM_READ or
STGM_SHARE_DENY_WRITE,
nil, 0, Stg));
PropSetStg := Stg as IPropertySetStorage;
OleCheck(PropSetStg.Open(FmtID_SummaryInformation,
STGM_READ or STGM_SHARE_EXCLUSIVE, PropStg));
for I := 2 to 19 do
begin
PropSpec[I].ulKind := PRSPEC_PROPID;
PropSpec[I].PropID := I;
end;
Rslt := PropStg.ReadMultiple(18, @PropSpec, @PropVariant);
OleCheck(Rslt);
if Rslt <> S_FALSE then for I := 2 to 19 do
begin
S := '';
if PropVariant[I].vt = VT_LPSTR then
if Assigned(PropVariant[I].pszVal) then
S := PropVariant[I].pszVal;
case I of
2: S := Format('Title: %s', [S]);
3: S := Format('Subject: %s', [S]);
4: S := Format('Author: %s', [S]);
5: S := Format('Keywords: %s', [S]);
6: S := Format('Comments: %s', [S]);
7: S := Format('Template: %s', [S]);
8: S := Format('Last saved by: %s', [S]);
9: S := Format('Revision number: %s', [S]);
10: S := Format('Total editing time: %g sec',
[Comp(PropVariant[I].filetime) / 1.0E9]);
11: S := Format('Last printed: %s',
[FileTimeToDateTimeStr(PropVariant[I].filetime)]);
12: S := Format('Create time/date: %s',
[FileTimeToDateTimeStr(PropVariant[I].filetime)]);
13: S := Format('Last saved time/date: %s',
[FileTimeToDateTimeStr(PropVariant[I].filetime)]);
14: S := Format('Number of pages: %d', [PropVariant[I].lVal]);
15: S := Format('Number of words: %d', [PropVariant[I].lVal]);
16: S := Format('Number of characters: %d',
[PropVariant[I].lVal]);
17:; // thumbnail
18: S := Format('Name of creating application: %s', [S]);
19: S := Format('Security: %.8x', [PropVariant[I].lVal]);
end;
if S <> '' then Result := Result + S + #13;
end;
finally
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if Opendialog1.Execute then
ShowMessage(GetDocInfo(opendialog1.FileName));
end;
Взято с сайта
Как прочитать MP3 ID3-Tag?
Как прочитать MP3 ID3-Tag?
{
Byte 1-3 = ID 'TAG'
Byte 4-33 = Titel / Title
Byte 34-63 = Artist
Byte 64-93 = Album
Byte 94-97 = Jahr / Year
Byte 98-127 = Kommentar / Comment
Byte 128 = Genre
}
type
TID3Tag = record
ID: string[3];
Titel: string[30];
Artist: string[30];
Album: string[30];
Year: string[4];
Comment: string[30];
Genre: Byte;
end;
const
Genres : array[0..146] of string =
('Blues','Classic Rock','Country','Dance','Disco','Funk','Grunge',
'Hip- Hop','Jazz','Metal','New Age','Oldies','Other','Pop','R&B',
'Rap','Reggae','Rock','Techno','Industrial','Alternative','Ska',
'Death Metal','Pranks','Soundtrack','Euro-Techno','Ambient',
'Trip-Hop','Vocal','Jazz+Funk','Fusion','Trance','Classical',
'Instrumental','Acid','House','Game','Sound Clip','Gospel','Noise',
'Alternative Rock','Bass','Punk','Space','Meditative','Instrumental Pop',
'Instrumental Rock','Ethnic','Gothic','Darkwave','Techno-Industrial','Electronic',
'Pop-Folk','Eurodance','Dream','Southern Rock','Comedy','Cult','Gangsta',
'Top 40','Christian Rap','Pop/Funk','Jungle','Native US','Cabaret','New Wave',
'Psychadelic','Rave','Showtunes','Trailer','Lo-Fi','Tribal','Acid Punk',
'Acid Jazz','Polka','Retro','Musical','Rock & Roll','Hard Rock','Folk',
'Folk-Rock','National Folk','Swing','Fast Fusion','Bebob','Latin','Revival',
'Celtic','Bluegrass','Avantgarde','Gothic Rock','Progressive Rock',
'Psychedelic Rock','Symphonic Rock','Slow Rock','Big Band','Chorus',
'Easy Listening','Acoustic','Humour','Speech','Chanson','Opera',
'Chamber Music','Sonata','Symphony','Booty Bass','Primus','Porn Groove',
'Satire','Slow Jam','Club','Tango','Samba','Folklore','Ballad',
'Power Ballad','Rhytmic Soul','Freestyle','Duet','Punk Rock','Drum Solo',
'Acapella','Euro-House','Dance Hall','Goa','Drum & Bass','Club-House',
'Hardcore','Terror','Indie','BritPop','Negerpunk','Polsk Punk','Beat',
'Christian Gangsta','Heavy Metal','Black Metal','Crossover','Contemporary C',
'Christian Rock','Merengue','Salsa','Thrash Metal','Anime','JPop','SynthPop');
var
Form1: TForm1;
implementation
{$R *.dfm}
function readID3Tag(FileName: string): TID3Tag;
var
FS: TFileStream;
Buffer: array [1..128] of Char;
begin
FS := TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite);
try
FS.Seek(-128, soFromEnd);
FS.Read(Buffer, 128);
with Result do
begin
ID := Copy(Buffer, 1, 3);
Titel := Copy(Buffer, 4, 30);
Artist := Copy(Buffer, 34, 30);
Album := Copy(Buffer, 64, 30);
Year := Copy(Buffer, 94, 4);
Comment := Copy(Buffer, 98, 30);
Genre := Ord(Buffer[128]);
end;
finally
FS.Free;
end;
end;
procedure TfrmMain.Button1Click(Sender: TObject);
begin
if OpenDialog1.Execute then
begin
with readID3Tag(OpenDialog1.FileName) do
begin
LlbID.Caption := 'ID: ' + ID;
LlbTitel.Caption := 'Titel: ' + Titel;
LlbArtist.Caption := 'Artist: ' + Artist;
LlbAlbum.Caption := 'Album: ' + Album;
LlbYear.Caption := 'Year: ' + Year;
LlbComment.Caption := 'Comment: ' + Comment;
if (Genre >= 0) and (Genre <=146) then
LlbGenre.Caption := 'Genre: ' + Genres[Genre]
else
LlbGenre.Caption := 'N/A';
end;
end;
end;
Взято с сайта
Как прочитать название порта принтера?
Как прочитать название порта принтера?
{... }
uses
printers, winspool;
function GetCurrentPrinterHandle: THandle;
const
Defaults: TPrinterDefaults = (pDatatype: nil; pDevMode: nil; DesiredAccess:
PRINTER_ACCESS_USE or PRINTER_ACCESS_ADMINISTER);
var
Device, Driver, Port: array[0..255] of char;
hDeviceMode: THandle;
begin
Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
if not OpenPrinter(@Device, Result, @Defaults) then
RaiseLastWin32Error;
end;
procedure TForm1.Button1Click(Sender: TObject);
procedure Display(const prefix: string; S: PChar);
begin
memo1.lines.add(prefix + string(S));
end;
var
pInfo: PPrinterInfo2;
bytesNeeded: DWORD;
hPrinter: THandle;
i: Integer;
begin
for i := 0 to printer.Printers.Count - 1 do
begin
Printer.PrinterIndex := i;
hPrinter := GetCurrentPrinterHandle;
try
GetPrinter(hPrinter, 2, nil, 0, @bytesNeeded);
pInfo := AllocMem(bytesNeeded);
try
GetPrinter(hPrinter, 2, pInfo, bytesNeeded, @bytesNeeded);
Display('ServerName: ', pInfo^.pServerName);
Display('PrinterName: ', pInfo^.pPrinterName);
Display('ShareName: ', pInfo^.pShareName);
Display('PortName: ', pInfo^.pPortName);
finally
FreeMem(pInfo);
end;
finally
ClosePrinter(hPrinter);
end;
end;
end;
Взято с
Delphi Knowledge BaseКак прочитать очередь печати?
Как прочитать очередь печати?
uses
Winspool, Printers;
function GetCurrentPrinterHandle: THandle;
var
Device, Driver, Port: array[0..255] of Char;
hDeviceMode: THandle;
begin
Printer.GetPrinter(Device, Driver, Port, hDeviceMode);
if not OpenPrinter(@Device, Result, nil) then
RaiseLastWin32Error;
end;
function SavePChar(p: PChar): PChar;
const
error: PChar = 'Nil';
begin
if not Assigned(p) then
Result := error
else
Result := p;
end;
procedure TForm1.Button1Click(Sender: TObject);
type
TJobs = array [0..1000] of JOB_INFO_1;
PJobs = ^TJobs;
var
hPrinter: THandle;
bytesNeeded, numJobs, i: Cardinal;
pJ: PJobs;
begin
hPrinter := GetCurrentPrinterHandle;
try
EnumJobs(hPrinter, 0, 1000, 1, nil, 0, bytesNeeded,
numJobs);
pJ := AllocMem(bytesNeeded);
if not EnumJobs(hPrinter, 0, 1000, 1, pJ, bytesNeeded,
bytesNeeded, numJobs) then
RaiseLastWin32Error;
memo1.Clear;
if numJobs = 0 then
memo1.Lines.Add('No jobs in queue')
else
for i := 0 to Pred(numJobs) do
memo1.Lines.Add(Format('Printer %s, Job %s, Status (%d): %s',
[SavePChar(pJ^[i].pPrinterName), SavePChar(pJ^[i].pDocument),
pJ^[i].Status, SavePChar(pJ^[i].pStatus)]));
finally
ClosePrinter(hPrinter);
end;
end;
Взято с сайта
Как прочитать пароль, скрытый за звездочками?
Как прочитать пароль, скрытый за звездочками?
Наверно так: хотя классов может быть больше
procedure TForm1.Timer1Timer(Sender: TObject);
var
Wnd : HWND;
lpClassName: array [0..$FF] of Char;
begin
Wnd := WindowFromPoint(Mouse.CursorPos);
GetClassName (Wnd, lpClassName, $FF);
if ((strpas(lpClassName) = 'TEdit') or (strpas(lpClassName) = 'EDIT')) then
PostMessage (Wnd, EM_SETPASSWORDCHAR, 0, 0);
end;
Автор ответа: Baa
Взято с Vingrad.ru
Здесь проблема: если страница памяти защищена, то её нельзя прочитать таким способом, но можно заменить PasswordChar(пример: поле ввода пароля в удаленном соединении)
Автор ответа: Mikel
Взято с Vingrad.ru
Как прочитать shortcut's link information?
Как прочитать shortcut's link information?
uses
ShlObj,
ComObj,
ActiveX,
CommCtrl;
type
PShellLinkInfoStruct = ^TShellLinkInfoStruct;
TShellLinkInfoStruct = record
FullPathAndNameOfLinkFile: array[0..MAX_PATH] of Char;
FullPathAndNameOfFileToExecute: array[0..MAX_PATH] of Char;
ParamStringsOfFileToExecute: array[0..MAX_PATH] of Char;
FullPathAndNameOfWorkingDirectroy: array[0..MAX_PATH] of Char;
Description: array[0..MAX_PATH] of Char;
FullPathAndNameOfFileContiningIcon: array[0..MAX_PATH] of Char;
IconIndex: Integer;
HotKey: Word;
ShowCommand: Integer;
FindData: TWIN32FINDDATA;
end;
procedure GetLinkInfo(lpShellLinkInfoStruct: PShellLinkInfoStruct);
var
ShellLink: IShellLink;
PersistFile: IPersistFile;
AnObj: IUnknown;
begin
// access to the two interfaces of the object
AnObj := CreateComObject(CLSID_ShellLink);
ShellLink := AnObj as IShellLink;
PersistFile := AnObj as IPersistFile;
// Opens the specified file and initializes an object from the file contents.
PersistFile.Load(PWChar(WideString(lpShellLinkInfoStruct^.FullPathAndNameOfLinkFile)), 0);
with ShellLink do
begin
// Retrieves the path and file name of a Shell link object.
GetPath(lpShellLinkInfoStruct^.FullPathAndNameOfFileToExecute,
SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfLinkFile),
lpShellLinkInfoStruct^.FindData,
SLGP_UNCPRIORITY);
// Retrieves the description string for a Shell link object.
GetDescription(lpShellLinkInfoStruct^.Description,
SizeOf(lpShellLinkInfoStruct^.Description));
// Retrieves the command-line arguments associated with a Shell link object.
GetArguments(lpShellLinkInfoStruct^.ParamStringsOfFileToExecute,
SizeOf(lpShellLinkInfoStruct^.ParamStringsOfFileToExecute));
// Retrieves the name of the working directory for a Shell link object.
GetWorkingDirectory(lpShellLinkInfoStruct^.FullPathAndNameOfWorkingDirectroy,
SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfWorkingDirectroy));
// Retrieves the location (path and index) of the icon for a Shell link object.
GetIconLocation(lpShellLinkInfoStruct^.FullPathAndNameOfFileContiningIcon,
SizeOf(lpShellLinkInfoStruct^.FullPathAndNameOfFileContiningIcon),
lpShellLinkInfoStruct^.IconIndex);
// Retrieves the hot key for a Shell link object.
GetHotKey(lpShellLinkInfoStruct^.HotKey);
// Retrieves the show (SW_) command for a Shell link object.
GetShowCmd(lpShellLinkInfoStruct^.ShowCommand);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
const
br = #13#10;
var
LinkInfo: TShellLinkInfoStruct;
s: string;
begin
FillChar(LinkInfo, SizeOf(LinkInfo), #0);
LinkInfo.FullPathAndNameOfLinkFile := 'C:\WINNT\Profiles\user\Desktop\FileName.lnk';
GetLinkInfo(@LinkInfo);
with LinkInfo do
s := FullPathAndNameOfLinkFile + br +
FullPathAndNameOfFileToExecute + br +
ParamStringsOfFileToExecute + br +
FullPathAndNameOfWorkingDirectroy + br +
Description + br +
FullPathAndNameOfFileContiningIcon + br +
IntToStr(IconIndex) + br +
IntToStr(LoByte(HotKey)) + br +
IntToStr(HiByte(HotKey)) + br +
IntToStr(ShowCommand) + br +
FindData.cFileName + br +
FindData.cAlternateFileName;
Memo1.Lines.Add(s);
end;
// Only for D3 or higher.
// for D1,D2 users: http://www.hitekdev.com/delphi/shellutlexamples.html
Взято с сайта
Как прочитать список возможностей принтера?
Как прочитать список возможностей принтера?
uses
Printers;
//------------------------------------------------------------------------------
// Printer Device Debugging Code to TMemo Componenet
// (c) - 1999 / by A. Weidauer
// alex.weiauer@huckfinn.de
//------------------------------------------------------------------------------
procedure GetDeviceSettings(DevCtrl: TMemo);
var
Sep: string;
//-----------------------------------------------
procedure MakeInt(S: string; key: Integer);
begin
S := UpperCase(S);
DevCtrl.Lines.Add(UpperCase(Format(' %36S = %d ',
[s, GetDeviceCaps(Printer.Handle, Key)])));
end;
//-----------------------------------------------
function StringToBits(S: string): string;
var
H: string;
i: Integer;
//-----------------------------------------------
function SubStr(C: Char): string;
begin
if c = '0' then SubStr := '0000';
if c = '1' then SubStr := '0001';
if c = '2' then SubStr := '0010';
if c = '3' then SubStr := '0011';
if c = '4' then SubStr := '0100';
if c = '5' then SubStr := '0101';
if c = '6' then SubStr := '0110';
if c = '7' then SubStr := '0111';
if c = '8' then SubStr := '1000';
if c = '9' then SubStr := '1001';
if c = 'A' then SubStr := '1010';
if c = 'B' then SubStr := '1011';
if c = 'C' then SubStr := '1100';
if c = 'D' then SubStr := '1101';
if c = 'E' then SubStr := '1110';
if c = 'F' then SubStr := '1111';
end;
//-----------------------------------------------
begin
StringToBits := '';
S := UpperCase(s);
H := '';
if Length(S) = 0 then Exit;
if Length(S) = 1 then S := '0000' + S;
if Length(S) = 2 then S := '000' + S;
if Length(S) = 3 then S := '00' + S;
if Length(S) = 4 then S := '0' + S;
for i := 1 to Length(s) do
H := H + ' ' + SubStr(S[i]);
StringToBits := H;
end;
//-----------------------------------------------
procedure MakeHex(S: string; key: Cardinal);
var
h: string;
begin
S := UpperCase(S);
h := Format('%X', [GetDeviceCaps(Printer.Handle, Key)]);
if Length(H) = 0 then Exit;
if Length(H) = 1 then H := '0000' + H;
if Length(H) = 2 then H := '000' + H;
if Length(H) = 3 then H := '00' + H;
if Length(H) = 4 then H := '0' + H;
DevCtrl.Lines.Add('');
DevCtrl.Lines.Add(SEP);
DevCtrl.Lines.Add('');
DevCtrl.Lines.Add(Format('%37S = Flags(%S) Key(%S)',
[s, h, StringToBits(H)]
));
// (( GetDeviceCaps(Printer.Handle,Key),
end;
//----------------------------------------------------
procedure MakeFlag(S: string; key, subKey: Cardinal);
var
i: Cardinal;
begin
S := UpperCase(S);
i := GetDeviceCaps(Printer.Handle, Key);
if i and SubKey <> 0 then
DevCtrl.Lines.Add(Format(' %34S = Flag(%4S) Key(%6D,%S)',
[s, 'ON ', SubKey, StringToBits(Format('%x', [SubKey]))]))
else
DevCtrl.Lines.Add(Format(' %34S = Flag(%4S) Key(%6D,%S)',
[s, 'OFF', SubKey, StringToBits(Format('%x', [SubKey]))]))
end;
//----------------------------------------------------
function TechnoToStr(i: Integer): string;
begin
TechnoToStr := '#ERROR# is Unknwon';
case i of
DT_PLOTTER: TechnoToStr := 'Vector Plotter';
DT_RASDISPLAY: TechnoToStr := 'Raster Display';
DT_RASPRINTER: TechnoToStr := 'Raster Printer';
DT_RASCAMERA: TechnoToStr := 'Raster Camera';
DT_CHARSTREAM: TechnoToStr := 'Character Stream';
DT_METAFILE: TechnoToStr := 'Metafile';
DT_DISPFILE: TechnoToStr := 'Display file';
end;
end;
//--Main Procedure
//----------------------------------------------------------
begin
DevCtrl.SetFocus;
DevCtrl.Visible := False;
if Printer.PrinterIndex < 0 then Exit;
// Device Organisation
try
if not (GetMapMode(Printer.Handle) = MM_TEXT) then
SetMapMode(Printer.Handle, MM_Text);
DevCtrl.Clear;
Sep := '______________________________________________________________________________________________';
DevCtrl.Lines.Add(sep);
DevCtrl.Lines.Add('');
DevCtrl.Lines.Add(' PRINTER : ' + Printer.Printers[Printer.PrinterIndex]);
DevCtrl.Lines.Add(sep);
DevCtrl.Lines.Add('');
DevCtrl.Lines.Add(sep);
DevCtrl.Lines.Add('');
DevCtrl.Lines.Add(Format('%36S = %D', ['NUMBER Of COPIES', Printer.Copies]));
if Printer.Orientation = poLandscape then
DevCtrl.Lines.Add(Format('%36S = LANDSCAPE', ['ORIENTATION']));
if Printer.Orientation = poPortrait then
DevCtrl.Lines.Add(Format('%36S = PORTRAIT', ['ORIENTATION']));
DevCtrl.Lines.Add(sep);
DevCtrl.Lines.Add('');
MakeInt('DRIVERVERSION', DRIVERVERSION);
DevCtrl.Lines.Add(Format(' %36S = %S', ['TECHNOLOGY',
UpperCase(TechnoToStr(GetDeviceCaps(Printer.Handle, Technology)))]));
DevCtrl.Lines.Add(sep);
DevCtrl.Lines.Add('');
MakeInt('WIDTH [mm]', HORZSIZE);
MakeInt('HEIGHT [mm]', VERTSIZE);
MakeInt('WIDTH [pix]', HORZRES);
MakeInt('HEIGHT [pix]', VERTRES);
DevCtrl.Lines.Add(sep);
DevCtrl.Lines.Add('');
MakeInt('Physical Width [pix]', PHYSICALWIDTH);
MakeInt('Physical Height[pix]', PHYSICALHEIGHT);
MakeInt('Physical Offset X [pix]', PHYSICALOFFSETX);
MakeInt('Physical Offset Y [pix]', PHYSICALOFFSETY);
MakeInt('SCALING FACTOR X', SCALINGFACTORX);
MakeInt('SCALING FACTOR Y', SCALINGFACTORY);
DevCtrl.Lines.Add(sep);
DevCtrl.Lines.Add('');
MakeInt('horizontal [DPI]', LOGPIXELSX);
MakeInt('vertial [DPI]', LOGPIXELSY);
MakeInt('BITS PER PIXEL', BITSPIXEL);
MakeInt('COLOR PLANES', PLANES);
DevCtrl.Lines.Add(sep);
DevCtrl.Lines.Add('');
MakeInt('NUMBER OF BRUSHES', NUMBRUSHES);
MakeInt('NUMBER OF PENS', NUMPENS);
MakeInt('NUMBER OF FONTS', NUMFONTS);
MakeInt('NUMBER OF COLORS', NUMCOLORS);
DevCtrl.Lines.Add(sep);
DevCtrl.Lines.Add('');
MakeInt('ASPECT Ratio X [DPI]', ASPECTX);
MakeInt('ASPECT Ratio Y [DPI]', ASPECTY);
MakeInt('ASPECT Ratio XY [DPI]', ASPECTXY);
DevCtrl.Lines.Add(sep);
DevCtrl.Lines.Add('');
MakeInt('SIZE OF PALETTE', SIZEPALETTE);
MakeInt('RESERVED TO SYSTEM PALETTE **', NUMRESERVED);
MakeInt('ACTUAL RASTER RESOLUTION **', COLORRES);
DevCtrl.Lines.Add('');
DevCtrl.Lines.Add(' **...only true if KEY RASTERCAPS(RC_PALETTE)= ON');
MakeFlag('... KEY RASTERCAPS (RC_PALETTE)', RasterCaps, RC_PALETTE);
DevCtrl.Lines.Add('');
MakeHex('Clipping Capablities ', ClipCaps);
DevCtrl.Lines.Add(sep);
DevCtrl.Lines.Add('');
MakeFlag('No Support ', ClipCaps, CP_NONE);
MakeFlag('Support Rectangles', ClipCaps, CP_RECTANGLE);
MakeFlag('Support PolyRegion 32 Bit', ClipCaps, CP_REGION);
MakeHex('Raster Printing Flags ', RasterCaps);
DevCtrl.Lines.Add(sep);
DevCtrl.Lines.Add('');
MakeFlag('Support Bitmap Transfer', RasterCaps, RC_BITBLT);
MakeFlag('Support Banding', RasterCaps, RC_BANDING);
MakeFlag('Support Scaling', RasterCaps, RC_SCALING);
MakeFlag('Support Bitmaps > 64 kByte', RasterCaps, RC_BITMAP64);
MakeFlag('Support features of Win 2.0', RasterCaps, RC_GDI20_OUTPUT);
MakeFlag('Support Set~/GetDIBITS()', RasterCaps, RC_DI_BITMAP);
MakeFlag('Support Palette Devices', RasterCaps, RC_PALETTE);
MakeFlag('Support SetDIBitsToDevice()', RasterCaps, RC_DIBTODEV);
MakeFlag('Support Floodfill', RasterCaps, RC_FLOODFILL);
MakeFlag('Support StretchBlt()', RasterCaps, RC_STRETCHBLT);
MakeFlag('Support StretchBID()', RasterCaps, RC_STRETCHDIB);
MakeFlag('Support DIBS', RasterCaps, RC_DEVBITS);
MakeHex('Curve Printion Flages', CurveCaps);
DevCtrl.Lines.Add(sep);
DevCtrl.Lines.Add('');
MakeFlag('No Curve support', CurveCaps, CC_NONE);
MakeFlag('Support Circles', CurveCaps, CC_Circles);
MakeFlag('Support Pie', CurveCaps, CC_PIE);
MakeFlag('Support Arces', CurveCaps, CC_CHORD);
MakeFlag('Support Ellipses', CurveCaps, CC_ELLIPSEs);
MakeFlag('Support WIDE FRAMES', CurveCaps, CC_WIDE);
MakeFlag('Support STYLED FRAMES', CurveCaps, CC_STYLED);
MakeFlag('Support WIDE&STYLED FRAMES', CurveCaps, CC_WIDESTYLED);
MakeFlag('Support INTERIORS', CurveCaps, CC_INTERIORS);
MakeFlag('Support ROUNDRECT', CurveCaps, CC_ROUNDRECT);
MakeHex('Line & Polygon Printing Flags', LineCaps);
DevCtrl.Lines.Add(sep);
DevCtrl.Lines.Add('');
MakeFlag('No Line Support', LineCaps, LC_NONE);
MakeFlag('Support Polylines', LineCaps, LC_PolyLine);
MakeFlag('Support Marker', LineCaps, LC_Marker);
MakeFlag('Support PolyMarker', LineCaps, LC_PolyMarker);
MakeFlag('Support Wide Lines', LineCaps, LC_WIDE);
MakeFlag('Support STYLED Lines', LineCaps, LC_STYLED);
MakeFlag('Support WIDE&STYLED Lines', LineCaps, LC_WIDESTYLED);
MakeFlag('Support Lines Interiors', LineCaps, LC_INTERIORS);
MakeHex('Polygon (Areal) Printing Flags', POLYGONALCAPS);
DevCtrl.Lines.Add(sep);
DevCtrl.Lines.Add('');
MakeFlag('No Polygon Support', PolygonalCaps, PC_NONE);
MakeFlag('Filling Alternate Polygons', PolygonalCaps, PC_POLYGON);
MakeFlag('Drawing Rectangles', PolygonalCaps, PC_RECTANGLE);
MakeFlag('Filling Winding Polygons', PolygonalCaps, PC_WINDPOLYGON);
MakeFlag('Drawing Trapezoid (??Flag)', PolygonalCaps, PC_Trapezoid);
MakeFlag('Drawing a ScanLine', PolygonalCaps, PC_SCANLINE);
MakeFlag('Drawing Wide Border', PolygonalCaps, PC_WIDE);
MakeFlag('Drawing Styled Border', PolygonalCaps, PC_STYLED);
MakeFlag('Drawing WIDE&STYLED Border', PolygonalCaps, PC_WIDESTYLED);
MakeFlag('Drawing Interiors', PolygonalCaps, PC_INTERIORS);
MakeHex('Text Printing Flags', TEXTCAPS);
DevCtrl.Lines.Add(sep);
DevCtrl.Lines.Add('');
MakeFlag('Support Character Output Precision', TextCaps, TC_OP_CHARACTER);
MakeFlag('Support Stroke Output Precision', TextCaps, TC_OP_STROKE);
MakeFlag('Support Stroke Clip Precision', TextCaps, TC_CP_STROKE);
MakeFlag('Support 90° Character Rotation', TextCaps, TC_CR_90);
MakeFlag('Support any Character Rotaion', TextCaps, TC_CR_ANY);
MakeFlag('Support Character Scaling in X&Y', TextCaps, TC_SF_X_YINDEP);
MakeFlag('Support Character Scaling REAL', TextCaps, TC_SA_DOUBLE);
MakeFlag('Support Character Scaling RATIONAL', TextCaps, TC_SA_INTEGER);
MakeFlag('Support Character Scaling EXACT', TextCaps, TC_SA_CONTIN);
MakeFlag('Support Character Weight REAL', TextCaps, TC_EA_DOUBLE);
MakeFlag('Support Character Italic', TextCaps, TC_IA_ABLE);
MakeFlag('Support Character Underline', TextCaps, TC_UA_ABLE);
MakeFlag('Support Character Strikeout', TextCaps, TC_SO_ABLE);
MakeFlag('Support Character as RASTER FONT', TextCaps, TC_RA_ABLE);
MakeFlag('Support Character as VECTOR FONT', TextCaps, TC_VA_ABLE);
MakeFlag('Reserved Flag ???', TextCaps, TC_Reserved);
MakeFlag('DEVICE NOT USE a SCROLLBIT BLOCK ?', TextCaps, TC_SCROLLBLT);
DevCtrl.Lines.Insert(0, '..THE RESULTS ARE:');
except
// MessageDlg('The Current Printer is not valid ! ',
// mtError,[mbok],0);
Printer.PrinterIndex := -1;
DevCtrl.Lines.Add(' ! The Printer is not valid !');
end;
DevCtrl.Visible := True;
DevCtrl.SetFocus;
end;
Взято с сайта
Как прочитать свойства видеофайла?
Как прочитать свойства видеофайла?
Below is some code to get some of the data. To use the DirectDraw/ DirectShow calls you need either the older DSHOW.PAS (DX6) or more current DirectShow.pas header conversion from the Project JEDI web site:
type
TDSMediaInfo = record
SurfaceDesc: TDDSurfaceDesc;
Pitch: integer;
PixelFormat: TPixelFormat;
MediaLength: Int64;
AvgTimePerFrame: Int64;
FrameCount: integer;
Width: integer;
Height: integer;
FileSize: Int64;
end;
function GetHugeFileSize(const FileName: string): int64;
var
FileHandle: hFile;
begin
FileHandle := FileOpen(FileName, fmOpenRead or fmShareDenyNone);
try
LARGE_INTEGER(Result).LowPart := GetFileSize(FileHandle, @LARGE_INTEGER(Result).HighPart);
if LARGE_INTEGER(Result).LowPart = $FFFFFFFF then
Win32Check(GetLastError = NO_ERROR);
finally
FileClose(FileHandle);
end;
end;
function GetMediaInfo(FileName: WideString): TDSMediaInfo;
var
DirectDraw: IDirectDraw;
AMStream: IAMMultiMediaStream;
MMStream: IMultiMediaStream;
PrimaryVidStream: IMediaStream;
DDStream: IDirectDrawMediaStream;
GraphBuilder: IGraphBuilder;
MediaSeeking: IMediaSeeking;
TimeStart, TimeStop: Int64;
DesiredSurface: TDDSurfaceDesc;
DDSurface: IDirectDrawSurface;
begin
if FileName = '' then
raise Exception.Create('No File Name Specified');
OleCheck(DirectDrawCreate(nil, DirectDraw, nil));
DirectDraw.SetCooperativeLevel(GetDesktopWindow(), DDSCL_NORMAL);
Result.FileSize := GetHugeFileSize(FileName);
AMStream := IAMMultiMediaStream(CreateComObject(CLSID_AMMultiMediaStream));
OleCheck(AMStream.Initialize(STREAMTYPE_READ, AMMSF_NOGRAPHTHREAD, nil));
OleCheck(AMStream.AddMediaStream(DirectDraw, MSPID_PrimaryVideo, 0, IMediaStream(nil^)));
OleCheck(AMStream.OpenFile(PWideChar(FileName), AMMSF_NOCLOCK));
AMStream.GetFilterGraph(GraphBuilder);
MediaSeeking := GraphBuilder as IMediaSeeking;
MediaSeeking.GetDuration(Result.MediaLength);
MMStream := AMStream as IMultiMediaStream;
OleCheck(MMStream.GetMediaStream(MSPID_PrimaryVideo, PrimaryVidStream));
DDStream := PrimaryVidStream as IDirectDrawMediaStream;
DDStream.GetTimePerFrame(Result.AvgTimePerFrame);
{Result.FrameCount := Result.MediaLength div Result.AvgTimePerFrame;}
{ TODO : Test for better accuracy }
Result.FrameCount := Round(Result.MediaLength / Result.AvgTimePerFrame);
Result.MediaLength := Result.FrameCount * Result.AvgTimePerFrame;
ZeroMemory(@DesiredSurface, SizeOf(DesiredSurface));
DesiredSurface.dwSize := Sizeof(DesiredSurface);
OleCheck(DDStream.GetFormat(TDDSurfaceDesc(nil^), IDirectDrawPalette(nil^),
DesiredSurface, DWord(nil^)));
Result.SurfaceDesc := DesiredSurface;
DesiredSurface.ddsCaps.dwCaps := DesiredSurface.ddsCaps.dwCaps or
DDSCAPS_OFFSCREENPLAIN or DDSCAPS_SYSTEMMEMORY;
DesiredSurface.dwFlags := DesiredSurface.dwFlags or DDSD_CAPS or DDSD_PIXELFORMAT;
{Create a surface here to get vital statistics}
OleCheck(DirectDraw.CreateSurface(DesiredSurface, DDSurface, nil));
OleCheck(DDSurface.GetSurfaceDesc(DesiredSurface));
Result.Pitch := DesiredSurface.lPitch;
if DesiredSurface.ddpfPixelFormat.dwRGBBitCount = 24 then
Result.PixelFormat := pf24bit
else if DesiredSurface.ddpfPixelFormat.dwRGBBitCount = 32 then
Result.PixelFormat := pf32bit;
Result.Width := DesiredSurface.dwWidth;
Result.Height := DesiredSurface.dwHeight;
end;
Взято с
Delphi Knowledge BaseКак прочитать свойство напрямую из его ресурса?
Как прочитать свойство напрямую из его ресурса?
Does anyone know if there is an easy way to load the value of a component's property directly from its resource without creating the component? Something like:
ifReadPropertyValue('Form1.Button1', 'width') > 1000 then
ShowMessage('You are about to create a big button!');
function TForm1.ReadProp(r: TReader): string;
begin
result := '';
{Determine the value type of the property, read it with the appropriate method of TReader
and convert it to string. Not all value types are implemented here but you get the idea.}
case r.NextValue of
vaInt8, vaInt16, vaInt32:
result := IntToStr(r.ReadInteger);
vaExtended:
result := FloatToStr(r.ReadFloat);
vaString:
result := r.ReadString;
else
r.SkipValue; {Not implemented}
end;
end;
procedure TForm1.ReadRes(PropPath: string; r: TReader);
var
p: string;
begin
{Skip the class name}
r.ReadStr;
{Construct the property path}
if PropPath = '' then
p := r.ReadStr
else
p := PropPath + '.' + r.ReadStr;
{Read all properties and its values and fill them into the memo}
while not r.EndOfList do
Memo1.Lines.Add(p + '.' + r.ReadStr + ' = ' + ReadProp(r));
{Skip over the end of the list of the properties of this component}
r.CheckValue(vaNull);
{Recursively read the properties of all sub-components}
while not r.EndOfList do
begin
ReadRes(p, r);
r.CheckValue(vaNull);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
strm: TResourceStream;
Reader: TReader;
begin
strm := TResourceStream.Create(HInstance, 'TForm1', RT_RCDATA);
Reader := TReader.Create(strm, 1024);
try
Memo1.Clear;
Reader.ReadSignature;
ReadRes('', Reader);
finally
Reader.Free;
strm.Free;
end;
end;
Only one small problem.
r.SkipValue was protected (in D5) but I hacked that out with the following code:
type THackReader = class(TReader);
{ ... }
THackReader(r).SkipValue;
And now it works like a charm.
Tip by Michael Duerig and Tjipke A. van der Plaats
Взято из
Как прочитать/установить принтер по умолчанию?
Как прочитать/установить принтер по умолчанию?
uses
Printers, Messages;
function GetDefaultPrinter: string;
var
ResStr: array[0..255] of Char;
begin
GetProfileString('Windows', 'device', '', ResStr, 255);
Result := StrPas(ResStr);
end;
procedure SetDefaultPrinter1(NewDefPrinter: string);
var
ResStr: array[0..255] of Char;
begin
StrPCopy(ResStr, NewdefPrinter);
WriteProfileString('windows', 'device', ResStr);
StrCopy(ResStr, 'windows');
SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, Longint(@ResStr));
end;
procedure SetDefaultPrinter2(PrinterName: string);
var
I: Integer;
Device: PChar;
Driver: PChar;
Port: PChar;
HdeviceMode: THandle;
aPrinter: TPrinter;
begin
Printer.PrinterIndex := -1;
GetMem(Device, 255);
GetMem(Driver, 255);
GetMem(Port, 255);
aPrinter := TPrinter.Create;
try
for I := 0 to Printer.Printers.Count - 1 do
begin
if Printer.Printers = PrinterName then
begin
aprinter.PrinterIndex := i;
aPrinter.getprinter(device, driver, port, HdeviceMode);
StrCat(Device, ',');
StrCat(Device, Driver);
StrCat(Device, Port);
WriteProfileString('windows', 'device', Device);
StrCopy(Device, 'windows');
SendMessage(HWND_BROADCAST, WM_WININICHANGE,
0, Longint(@Device));
end;
end;
finally
aPrinter.Free;
end;
FreeMem(Device, 255);
FreeMem(Driver, 255);
FreeMem(Port, 255);
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
label1.Caption := GetDefaultPrinter2;
end;
//Fill the combobox with all available printers
procedure TForm1.FormCreate(Sender: TObject);
begin
Combobox1.Items.Clear;
Combobox1.Items.AddStrings(Printer.Printers);
end;
//Set the selected printer in the combobox as default printer
procedure TForm1.Button2Click(Sender: TObject);
begin
SetDefaultPrinter(Combobox1.Text);
end;
Взято с сайта
Как прочитать весь список Published методов?
Как прочитать весь список Published методов?
procedureEnumMethods( aClass: TClass; lines: TStrings );
type
TMethodtableEntry = packed Record
len: Word;
adr: Pointer;
name: ShortString;
end;
{Note: name occupies only the size required, so it is not a true shortstring! The actual
entry size is variable, so the method table is not an array of TMethodTableEntry!}
var
pp: ^Pointer;
pMethodTable: Pointer;
pMethodEntry: ^TMethodTableEntry;
i, numEntries: Word;
begin
if aClass = nil then
Exit;
pp := Pointer(Integer( aClass ) + vmtMethodtable);
pMethodTable := pp^;
lines.Add(format('Class %s: method table at %p', [aClass.Classname, pMethodTable ] ));
if pMethodtable <> nil then
begin
{first word of the method table contains the number of entries}
numEntries := PWord( pMethodTable )^;
lines.Add(format(' %d published methods', [numEntries] ));
{make pointer to first method entry, it starts at the second word of the table}
pMethodEntry := Pointer(Integer( pMethodTable ) + 2);
for i := 1 to numEntries do
begin
with pMethodEntry^ do
lines.Add(format( ' %d: len: %d, adr: %p, name: %s', [i, len, adr, name] ));
{make pointer to next method entry}
pMethodEntry := Pointer(Integer( pMethodEntry ) + pMethodEntry^.len);
end;
end;
EnumMethods( aClass.ClassParent, lines );
end;
procedure TForm2.Button1Click(Sender: TObject);
begin
memo1.clear;
EnumMethods( Classtype, memo1.lines );
end;
Взято из
function GetComponentProperties(Instance: TPersistent; AList: TStrings): Integer;
var
I, Count: Integer;
PropInfo: PPropInfo;
PropList: PPropList;
begin
Result := 0;
Count := GetTypeData(Instance.ClassInfo)^.PropCount;
if Count > 0 then
begin
GetMem(PropList, Count * SizeOf(Pointer));
try
GetPropInfos(Instance.ClassInfo, PropList);
for I := 0 to Count - 1 do
begin
PropInfo := PropList^[I];
if PropInfo = nil then
Break;
if IsStoredProp(Instance, PropInfo) then
begin
{
case PropInfo^.PropType^.Kind of
tkInteger:
tkMethod:
tkClass:
...
end;
}
end;
Result := AList.Add(PropInfo^.Name);
end;
finally
FreeMem(PropList, Count * SizeOf(Pointer));
end;
end;
end;
Tip by Grega Loboda
uses
TypInfo
procedure ListProperties(AInstance: TPersistent; AList: TStrings);
var
i: integer;
pInfo: PTypeInfo;
pType: PTypeData;
propList: PPropList;
propCnt: integer;
tmpStr: string;
begin
pInfo := AInstance.ClassInfo;
if (pInfo = nil) or (pInfo^.Kind <> tkClass) then
raise Exception.Create('Invalid type information');
pType := GetTypeData(pInfo); {Pointer to TTypeData}
AList.Add('Class name: ' + pInfo^.Name);
{If any properties, add them to the list}
propCnt := pType^.PropCount;
if propCnt > 0 then
begin
AList.Add(EmptyStr);
tmpStr := IntToStr(propCnt) + ' Propert';
if propCnt > 1 then
tmpStr := tmpStr + 'ies'
else
tmpStr := tmpStr + 'y';
AList.Add(tmpStr);
FillChar(tmpStr[1], Length(tmpStr), '-');
AList.Add(tmpStr);
{Get memory for the property list}
GetMem(propList, sizeOf(PPropInfo) * propCnt);
try
{Fill in the property list}
GetPropInfos(pInfo, propList);
{Fill in info for each property}
for i := 0 to propCnt - 1 do
AList.Add(propList[i].Name+': '+propList[i].PropType^.Name);
finally
FreeMem(propList, sizeOf(PPropInfo) * propCnt);
end;
end;
end;
function GetPropertyList(AControl: TPersistent; AProperty: string): PPropInfo;
var
i: integer;
props: PPropList;
typeData: PTypeData;
begin
Result := nil;
if (AControl = nil) or (AControl.ClassInfo = nil) then
Exit;
typeData := GetTypeData(AControl.ClassInfo);
if (typeData = nil) or (typeData^.PropCount = 0) then
Exit;
GetMem(props, typeData^.PropCount * SizeOf(Pointer));
try
GetPropInfos(AControl.ClassInfo, props);
for i := 0 to typeData^.PropCount - 1 do
begin
with Props^[i]^ do
if (Name = AProperty) then
result := Props^[i];
end;
finally
FreeMem(props);
end;
end;
And calling this code by:
ListProperties(TProject(treeview1.items[0].data), memo3.lines);
My tProject is defined as
type
TProject = class(tComponent)
private
FNaam: string;
procedure SetNaam(const Value: string);
public
constructor Create(AOwner: tComponent);
destructor Destroy;
published
property Naam: string read FNaam write SetNaam;
end;
Also note the output, there seem to be 2 standard properties (Name and Tag) !
Memo3
Class name: TProject
3 Properties
-------------------
Name: TComponentName
Tag: Integer
Naam: String
Tip by Ronan van Riet
Взято из
Как прочитать владельца файла?
Как прочитать владельца файла?
// When you create a file or directory, you become the owner of it.
// With GetFileOwner you get the owner of a file.
function GetFileOwner(FileName: string;
var Domain, Username: string): Boolean;
var
SecDescr: PSecurityDescriptor;
SizeNeeded, SizeNeeded2: DWORD;
OwnerSID: PSID;
OwnerDefault: BOOL;
OwnerName, DomainName: PChar;
OwnerType: SID_NAME_USE;
begin
GetFileOwner := False;
GetMem(SecDescr, 1024);
GetMem(OwnerSID, SizeOf(PSID));
GetMem(OwnerName, 1024);
GetMem(DomainName, 1024);
try
if not GetFileSecurity(PChar(FileName),
OWNER_SECURITY_INFORMATION,
SecDescr, 1024, SizeNeeded) then
Exit;
if not GetSecurityDescriptorOwner(SecDescr,
OwnerSID, OwnerDefault) then
Exit;
SizeNeeded := 1024;
SizeNeeded2 := 1024;
if not LookupAccountSID(nil, OwnerSID, OwnerName,
SizeNeeded, DomainName, SizeNeeded2, OwnerType) then
Exit;
Domain := DomainName;
Username := OwnerName;
finally
FreeMem(SecDescr);
FreeMem(OwnerName);
FreeMem(DomainName);
end;
GetFileOwner := True;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Domain, Username: string;
begin
GetFileOwner('YourFile.xyz', domain, username);
ShowMessage(username + '@' + domain);
end;
// Note: Only works unter NT.
Взято с сайта
Как прочитать время компиляции проги?
Как прочитать время компиляции проги?
Дату компилляции вытащить нельзя. Можно дату Build (т.е. дату когда ты сделал опрерацию Build All, или самую первую компилляцию)
1) Ставим библиотеку RxLib
2) Идем в опции проэкта, закладка Version Info, отмечаем птичкой - include version info
3) В коде пишем следующее
uses
Rxverinf;
procedure TForm1.Button1Click(Sender: TObject);
begin
with TVersionInfo.create(paramstr(0)) do
try
caption := datetimetostr(verfiledate);
finally
free;
end;
end;
Автор ответа: Vit
Взято с Vingrad.ru
Как прочитать заголовок wav файла?
Как прочитать заголовок wav файла?
type
TWaveHeader = record
ident1: array[0..3] of Char; // Must be "RIFF"
len: DWORD; // Remaining length after this header
ident2: array[0..3] of Char; // Must be "WAVE"
ident3: array[0..3] of Char; // Must be "fmt "
reserv: DWORD; // Reserved 4 bytes
wFormatTag: Word; // format type
nChannels: Word; // number of channels (i.e. mono, stereo, etc.)
nSamplesPerSec: DWORD; //sample rate
nAvgBytesPerSec: DWORD; //for buffer estimation
nBlockAlign: Word; //block size of data
wBitsPerSample: Word; //number of bits per sample of mono data
cbSize: Word; //the count in bytes of the size of
ident4: array[0..3] of Char; //Must be "data"
end;
With this structure you can get all the information's about a wave file you want to.
After this header following the wave data which contains the data for playing the wave file.
Now we trying to get the information's from a wave file. To be sure it's really a wave file, we test the information's:
function GetWaveHeader(FileName: TFilename): TWaveHeader;
const
riff = 'RIFF';
wave = 'WAVE';
var
f: TFileStream;
w: TWaveHeader;
begin
if not FileExists(Filename) then
exit; //exit the function if the file does not exists
try
f := TFileStream.create(Filename, fmOpenRead);
f.Read(w, Sizeof(w)); //Reading the file header
if w.ident1 <> riff then
begin //Test if it is a RIFF file, otherwise exit
Showmessage('This is not a RIFF File');
exit;
end;
if w.ident2 <> wave then
begin //Test if it is a wave file, otherwise exit
Showmessage('This is not a valid wave file');
exit;
end;
finally
f.free;
end;
Result := w;
end;
Взято с
Delphi Knowledge BaseКак программе удалить саму себя?
Как программе удалить саму себя?
Первый способ:
uses
Windows, SysUtils;
procedure DeleteMe;
var
BatchFile: TextFile;
BatchFileName: string;
ProcessInfo: TProcessInformation;
StartUpInfo: TStartupInfo;
begin
{ создаём бат-файл в директории приложения }
BatchFileName := ExtractFilePath(ParamStr(0)) + '$$336699.bat';
{ открываем и записываем в файл }
AssignFile(BatchFile, BatchFileName);
Rewrite(BatchFile);
Writeln(BatchFile, ':try');
Writeln(BatchFile, 'del "' + ParamStr(0) + '"');
Writeln(BatchFile,
'if exist "' + ParamStr(0) + '"' + ' goto try');
Writeln(BatchFile, 'del "' + BatchFileName + '"');
CloseFile(BatchFile);
FillChar(StartUpInfo, SizeOf(StartUpInfo), $00);
StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;
StartUpInfo.wShowWindow := SW_HIDE;
if CreateProcess(nil, PChar(BatchFileName), nil, nil,
False, IDLE_PRIORITY_CLASS, nil, nil, StartUpInfo,
ProcessInfo) then
begin
CloseHandle(ProcessInfo.hThread);
CloseHandle(ProcessInfo.hProcess);
end;
end;
А вот тот же способ, но немного модифицированный:
program delete2;
uses
SysUtils,
windows;
var
BatchFile: TextFile;
BatchFileName : string;
TM : Cardinal;
TempMem : PChar;
begin
BatchFileName:=ExtractFilePath(ParamStr(0))+ '$$336699.bat';
AssignFile(BatchFile, BatchFileName);
Rewrite(BatchFile);
Writeln(BatchFile,':try');
Writeln(BatchFile,'del "' + ParamStr(0) + '"');
Writeln(BatchFile,'if exist "' + ParamStr(0) + '" goto try');
Writeln(BatchFile,'del "' + BatchFileName + '"');
CloseFile(BatchFile);
TM:=70;
GetMem (TempMem,TM);
GetShortPathName (pchar(BatchFileName), TempMem, TM);
BatchFileName:=TempMem;
FreeMem(TempMem);
winexec(Pchar(BatchFileName),sw_hide);
halt;
end.
Второй способ:
procedure DeleteSelf;
var
module: HModule;
buf: array[0..MAX_PATH - 1] of char;
p: ULong;
hKrnl32: HModule;
pExitProcess,
pDeleteFile,
pFreeLibrary: pointer;
begin
module := GetModuleHandle(nil);
GetModuleFileName(module, buf, SizeOf(buf));
CloseHandle(THandle(4));
p := ULONG(module) + 1;
hKrnl32 := GetModuleHandle('kernel32');
pExitProcess := GetProcAddress(hKrnl32, 'ExitProcess');
pDeleteFile := GetProcAddress(hKrnl32, 'DeleteFileA');
pFreeLibrary := GetProcAddress(hKrnl32, 'FreeLibrary');
asm
lea eax, buf
push 0
push 0
push eax
push pExitProcess
push p
push pDeleteFile
push pFreeLibrary
ret
end;
end;
Взято с Исходников.ru
Как программно добавить принтер?
Как программно добавить принтер?
Чтобы программно добавить принтер, необходимо воспользоваться API функцией AddPrinter, которая имеет три параметра:
·Имя принтера
·Уровень печати
·Описание принтера
Следующий пример является надстройкой для этой функции. Для этого необходимо знать Имя принтера, которое будет отображаться в Проводнике, имя порта, к которому подключён принтер (т.е. LPT1:), имя драйвера (прийдётся посмотреть вручную) и имя процессора печати (который обычно "winprint").
unit unit_AddPrinter;
interface
function AddAPrinter(PrinterName, PortName,
DriverName, PrintProcessor: string): boolean;
implementation
uses
SysUtils,
WinSpool,
Windows;
function AddAPrinter(PrinterName, PortName,
DriverName, PrintProcessor: string): boolean;
var
pName: PChar;
Level: DWORD;
pPrinter: PPrinterInfo2;
begin
pName := nil;
Level := 2;
New(pPrinter);
pPrinter^.pServerName := nil;
pPrinter^.pShareName := nil;
pPrinter^.pComment := nil;
pPrinter^.pLocation := nil;
pPrinter^.pDevMode := nil;
pPrinter^.pSepFile := nil;
pPrinter^.pDatatype := nil;
pPrinter^.pParameters := nil;
pPrinter^.pSecurityDescriptor := nil;
pPrinter^.Attributes := 0;
pPrinter^.Priority := 0;
pPrinter^.DefaultPriority := 0;
pPrinter^.StartTime := 0;
pPrinter^.UntilTime := 0;
pPrinter^.Status := 0;
pPrinter^.cJobs := 0;
pPrinter^.AveragePPM :=0;
pPrinter^.pPrinterName := PCHAR(PrinterName);
pPrinter^.pPortName := PCHAR(PortName);
pPrinter^.pDriverName := PCHAR(DriverName);
pPrinter^.pPrintProcessor := PCHAR(PrintProcessor);
if AddPrinter(pName, Level, pPrinter) <> 0 then
Result := true
else
begin
// ShowMessage(inttostr(GetlastError));
Result := false;
end;
end;
end.
Взято с
Как программно двигать курсор мышки?
Как программно двигать курсор мышки?
Следующий пример показывает, как "подтолкнуть мышку" без вмешательства пользователя.
procedure TForm1.Button1Click(Sender: TObject);
var
pt : TPoint;
begin
Application.ProcessMessages;
Screen.Cursor := CrHourglass;
GetCursorPos(pt);
SetCursorPos(pt.x + 1, pt.y + 1);
Application.ProcessMessages;
SetCursorPos(pt.x - 1, pt.y - 1);
end;
Взято с Исходников.ru
Как программно реализовать Cut, Copy и Paste?
Как программно реализовать Cut, Copy и Paste?
Следущие операции производятся с активным контролом на форме:
procedure TForm1.Cut1Click(Sender: TObject);
begin
SendMessage (ActiveControl.Handle, WM_Cut, 0, 0);
end;
procedure TForm1.Copy1Click(Sender: TObject);
begin
SendMessage (ActiveControl.Handle, WM_Copy, 0, 0);
end;
procedure TForm1.Paste1Click(Sender: TObject);
begin
SendMessage (ActiveControl.Handle, WM_Paste, 0, 0);
end;
Если Вы разрабатываете приложение MDI, то необходимо отправлять сообщение в активное дочернее окно, т.е. использовать: ActiveMDIChild.ActiveControl.Handle
Взято с Исходников.ru
