|
:: MVP ::
|
|
|
:: RSS ::
|
|
|
Как рассчитать размеры миниатюры, чтобы вписать ее в заданную область?
var
Bmp: TBitmap;
// Вычисление множителя для масштабирования картинки (миниатюры)
// SourceWidth, SourceHeight - размеры исходного изображения
// PreviewWidth, PreviewHeight - размеры, в которые изображение нужно вписать
function CalcFactor( SourceWidth, SourceHeight, PreviewWidth, PreviewHeight: Integer ): Double;
begin
if ( PreviewWidth < SourceWidth ) or ( PreviewHeight < SourceHeight ) then
Result := Min( PreviewWidth / SourceWidth, PreviewHeight / SourceHeight )
else
Result := 1;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Factor: Double;
NewWidth, NewHeight: Integer;
begin
// Допустим в переменной Bmp: TBitmap хранится изображение,
// для которого нужно вычислить размер его миниатюры
Factor := CalcFactor( Bmp.Width, Bmp.Height, 100, 100 );
NewWidth := Round( Factor * Bmp.Width ); // Ширина миниатюры
NewHeight := Round( Factor * Bmp.Height ); // Высота миниатюры
end;
|
Как извлечь иконку из файла (.exe, .dll, .cpl и др.) по индексу?
// Способ первый
{$IFDEF UNICODE}
function PrivateExtractIcons(lpszFile: PChar; nIconIndex, cxIcon, cyIcon: integer; phicon: PHANDLE; piconid: PDWORD; nicon, flags: DWORD): DWORD;
stdcall ; external 'user32.dll' name 'PrivateExtractIconsW';
{$ELSE}
function PrivateExtractIcons(lpszFile: PChar; nIconIndex, cxIcon, cyIcon: integer; phicon: PHANDLE; piconid: PDWORD; nicon, flags: DWORD): DWORD;
stdcall ; external 'user32.dll' name 'PrivateExtractIconsA';
{$ENDIF}
function ExtractIcons( SourceFile: string; IconIndex, cxIcon, cyIcon: Integer;
TargetFile: string ): Boolean;
var
hIcon: THandle;
nIconId: DWORD;
Icon: TIcon;
begin
Result := False;
if PrivateExtractIcons( PWideChar( SourceFile ), IconIndex, cxIcon, cyIcon, @hIcon,
@nIconId, 1, LR_LOADFROMFILE ) <> 0 then
try
Icon := TIcon.Create;
try
Icon.Handle := hIcon;
Icon.SaveToFile( TargetFile );
Result := True;
finally
Icon.Free;
end;
finally
DestroyIcon( hIcon );
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if ExtractIcons( 'Shell32.dll', 15, 256, 256, 'c:\SavedIcon.ico' ) then
ShowMessage( 'Иконка сохранена.' );
end;
// Способ второй
uses
{...,} ShellAPI;
procedure TForm1.Button1Click(Sender: TObject);
begin
Image1.Picture.Icon.Handle :=
ExtractIcon(HInstance, PChar('c:\Windows\explorer.exe'), 0);
end;
// Способ третий
uses
{...,} ShellAPI;
procedure TForm1.Button1Click(Sender: TObject);
const
FileName = 'c:\Windows\explorer.exe';
var
Icon: TIcon;
Icon32, Icon16: HICON;
i: Integer;
begin
try
// Так можно получить количество иконок в файле
// ExtractIconEx(PChar(FileName), -1, Icon16, Icon32, 0);
i := 0;
while Integer(ExtractIconEx(PChar(FileName), i, Icon16, Icon32, 1)) > 0 do
begin
Icon := TIcon.Create;
Icon.Handle := Icon32;
ImageList1.AddIcon(Icon);
Icon.Free;
Inc(i);
end;
except
on e: Exception do
//
end;
end;
|
Как нарисовать диск и окружность со сглаживаниему?
uses
{...,} Math;
type
TForm1 = class(TForm)
Button1: TButton;
imMain: TImage;
procedure Button1Click(Sender: TObject);
private
public
end;
implementation
procedure DrawDisk( Bitmap: TBitmap; CenterX, CenterY, Radius, Feather: Single );
// Draw a disk on Bitmap. Bitmap must be a 256 color (pf8bit) palette bitmap,
// and parts outside the disk will get palette index 0, parts inside will get
// palette index 255, and in the antialiased area (feather), the pixels will
// get values inbetween.
// ***Parameters***
// Bitmap:
// The bitmap to draw on
// CenterX, CenterY:
// The center of the disk (float precision). Note that [0, 0] would be the
// center of the first pixel. To draw in the exact middle of a 100x100 bitmap,
// use CenterX = 49.5 and CenterY = 49.5
// Radius:
// The radius of the drawn disk in pixels (float precision)
// Feather:
// The feather area. Use 1 pixel for a 1-pixel antialiased area. Pixel centers
// outside 'Radius + Feather / 2' become 0, pixel centers inside 'Radius - Feather/2'
// become 255. Using a value of 0 will yield a bilevel image.
// Copyright (c) 2003 Nils Haeck M.Sc. www.simdesign.nl
var
x, y: integer;
LX, RX, LY, RY: integer;
Fact: integer;
RPF2, RMF2: single;
P: PByteArray;
SqY, SqDist: single;
sqX: array of single;
begin
// Determine some helpful values (singles)
RPF2 := Sqr( Radius + Feather/2 );
RMF2 := Sqr( Radius - Feather/2 );
// Determine bounds:
LX := Max( Floor( CenterX - RPF2 ), 0 );
RX := Min( Ceil( CenterX + RPF2 ), Bitmap.Width - 1 );
LY := Max( Floor( CenterY - RPF2 ), 0 );
RY := Min(Ceil( CenterY + RPF2 ), Bitmap.Height - 1 );
// Optimization run: find squares of X first
SetLength( SqX, RX - LX + 1 );
for x := LX to RX do
SqX[x-LX] := Sqr( x - CenterX );
// Loop through Y values
for y := LY to RY do
begin
P := Bitmap.Scanline[y];
SqY := Sqr( y - CenterY );
// Loop through X values
for x := LX to RX do
begin
// determine squared distance from center for this pixel
SqDist := SqY + SqX[x - LX];
// inside inner circle? Most often..
if sqdist < RMF2 then
begin
// inside the inner circle.. just give the scanline the new color
P[x] := 255
end
else
begin
// inside outer circle?
if sqdist < RPF2 then
begin
// We are inbetween the inner and outer bound, now mix the color
Fact := Round( ( ( Radius - Sqrt( SqDist ) ) * 2 / Feather ) * 127.5 + 127.5 );
P[x] := Max( 0, Min( Fact, 255 ) ); // just in case limit to [0, 255]
end
else
begin
P[x] := 0;
end;
end;
end;
end;
end;
procedure DrawCircle( Bitmap: TBitmap; CenterX, CenterY, Radius, LineWidth, Feather: Single );
// Draw a circle on Bitmap. Bitmap must be a 256 color (pf8bit) palette bitmap,
// and parts outside the circle will get palette index 0, parts inside will get
// palette index 255, and in the antialiased area (feather), the pixels will
// get values inbetween.
// ***Parameters***
// Bitmap:
// The bitmap to draw on
// CenterX, CenterY:
// The center of the circle (float precision). Note that [0, 0] would be the
// center of the first pixel. To draw in the exact middle of a 100x100 bitmap,
// use CenterX = 49.5 and CenterY = 49.5
// Radius:
// The radius of the drawn circle in pixels (float precision)
// LineWidth
// The line width of the drawn circle in pixels (float precision)
// Feather:
// The feather area. Use 1 pixel for a 1-pixel antialiased area. Pixel centers
// outside 'Radius + Feather / 2' become 0, pixel centers inside 'Radius - Feather/2'
// become 255. Using a value of 0 will yield a bilevel image. Note that Feather
// must be equal or smaller than LineWidth (or it will be adjusted internally)
// Copyright (c) 2003 Nils Haeck M.Sc. www.simdesign.nl
var
x, y: integer;
LX, RX, LY, RY: integer;
Fact: integer;
ROPF2, ROMF2, RIPF2, RIMF2: single;
OutRad, InRad: single;
P: PByteArray;
SqY, SqDist: single;
sqX: array of single;
begin
// Determine some helpful values (singles)
OutRad := Radius + LineWidth/2;
InRad := Radius - LineWidth/2;
ROPF2 := Sqr( OutRad + Feather/2 );
ROMF2 := Sqr( OutRad - Feather/2 );
RIPF2 := Sqr( InRad + Feather/2 );
RIMF2 := Sqr( InRad - Feather/2 );
// Determine bounds:
LX := Max( Floor( CenterX - ROPF2 ), 0 );
RX := Min( Ceil ( CenterX + ROPF2 ), Bitmap.Width - 1 );
LY := Max( Floor( CenterY - ROPF2 ), 0 );
RY := Min( Ceil ( CenterY + ROPF2 ), Bitmap.Height - 1 );
// Checks
if Feather > LineWidth then
Feather := LineWidth;
// Optimization run: find squares of X first
SetLength( SqX, RX - LX + 1 );
for x := LX to RX do
SqX[x - LX] := Sqr( x - CenterX );
// Loop through Y values
for y := LY to RY do
begin
P := Bitmap.Scanline[y];
SqY := Sqr( y - CenterY );
// Loop through X values
for x := LX to RX do
begin
// determine squared distance from center for this pixel
SqDist := SqY + SqX[x - LX];
// now first check if we're completely inside (most often)
if SqDist < RIMF2 then
begin
// We're on the disk inside everything
P[x] := 0;
end
else
begin
// completely outside?
if SqDist < ROPF2 then
begin
// inside outer line - feather?
if SqDist < ROMF2 then
begin
// check if we're in inside feather area
if SqDist < RIPF2 then
begin
// We are in the feather area of inner line, now mix the color
Fact := Round( ( ( Sqrt( SqDist ) - InRad ) * 2 / Feather ) * 127.5 + 127.5 );
P[x] := Max( 0, Min( Fact, 255 ) ); // just in case limit to [0, 255]
end
else
begin
// on the line
P[x] := 255;
end;
end
else
begin
// We are in the feather area of outer line, now mix the color
Fact := Round( ( ( OutRad - Sqrt( SqDist ) ) * 2 / Feather ) * 127.5 + 127.5 );
P[x] := Max( 0, Min( Fact, 255 ) ); // just in case limit to [0, 255]
end;
end
else
begin
// outside everything
P[x] := 0;
end;
end;
end;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
// Create a 256-color bitmap and call the DrawCircle procedure
var
i, y: integer;
ABitmap: TBitmap;
pal: PLogPalette;
hpal: HPALETTE;
ColRGB, BgrRGB: integer;
ACenterX, ACenterY,
ARadius, AFeather,
ALineWidth: single;
begin
ABitmap := TBitmap.Create;
try
// 8 bits per pixel
ABitmap.PixelFormat := pf8bit;
// Set width and height
ABitmap.Width := 300;
ABitmap.Height := 300;
// Create a gradient palette between foreground and background color
GetMem( pal, SizeOf( TLogPalette ) + SizeOf( TPaletteEntry ) * 255 );
try
pal.palVersion := $300;
pal.palNumEntries := 256;
ColRGB := ColorToRGB( clWhite );
BgrRGB := ColorToRGB( clBlack );
for i := 0 to 255 do
begin
pal.palPalEntry[i].peRed := Round( i / 255 * ( ColRGB and $FF ) + ( 255 - i ) / 255 * ( BgrRGB and $FF ) );
pal.palPalEntry[i].peGreen := Round( i / 255 * ( ColRGB shr 8 and $FF ) + ( 255 - i ) / 255 * ( BgrRGB shr 8 and $FF ) );
pal.palPalEntry[i].peBlue := Round( i / 255 * ( ColRGB shr 16 and $FF ) + ( 255 - i ) / 255 * ( BgrRGB shr 16 and $FF ) );
end;
hpal := CreatePalette( pal^ );
if hpal <> 0 then
ABitmap.Palette := hpal;
finally
FreeMem( pal );
end;
// Fill bitmap with background color
for y := 0 to ABitmap.Height-1 do
FillChar( ABitmap.Scanline[y]^, ABitmap.Width, 0 );
// Get data from form
ACenterX := 150;
ACenterY := 150;
ARadius := 135.5;
ALineWidth := 10;
AFeather := 5;
// Рисуем диск
DrawDisk( ABitmap, ACenterX, ACenterY, ARadius, AFeather );
// Рисуем окружность
// DrawCircle( ABitmap, ACenterX, ACenterY, ARadius, ALineWidth, AFeather );
// Assign to image
imMain.Picture.Bitmap.Assign( ABitmap );
finally
ABitmap.Free;
end;
end;
|
Как вытащить маску из TIcon?
type
TForm1 = class(TForm)
procedure FormPaint(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
Mask: TBitmap;
public
end;
implementation
procedure TForm1.FormCreate(Sender: TObject);
var
IconInfo: TIconInfo;
begin
Mask := TBitmap.Create;
GetIconInfo( Application.Icon.Handle, IconInfo );
Mask.Handle := IconInfo.hbmMask;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Mask.Free;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
BitBlt( Canvas.Handle, 0, 0, Mask.Width, Mask.Height,
Mask.Canvas.Handle, 0, 0, SRCCOPY );
end;
|
Как начертить hexagon?
uses
{...,} Math;
procedure PlotPolygon( const Canvas: TCanvas; const N: Integer; const R: Single;
const XC: Integer; const YC: Integer );
type
TPolygon = array of TPoint;
var
Polygon: TPolygon;
I: Integer;
C: Extended;
S: Extended;
A: Single;
begin
SetLength( Polygon, N );
A := 2 * Pi / N;
for I := 0 to ( N - 1 ) do
begin
SinCos( I * A, S, C );
Polygon[I].X := XC + Round( R * C );
Polygon[I].Y := YC + Round( R * S );
end;
Canvas.Polygon( Polygon );
end;
procedure TForm1.Button1Click(Sender: TObject);
var
W: Single;
H: Single;
X: Integer;
Y: Integer;
const
N = 6;
R = 10;
begin
W := 1.5 * R;
H := R * Sqrt( 3 );
for X := 0 to Round( ClientWidth / W ) do
for Y := 0 to Round( ClientHeight / H ) do
if Odd( X ) then
PlotPolygon( Canvas, N, R, Round( X * W ), Round( ( Y + 0.5 ) * H ) )
else
PlotPolygon( Canvas, N, R, Round( X * W ), Round( Y * H ) );
end;
|
Как вывести надпись на Canvas с эффектом 3D?
procedure ExtFont( Canvas: TCanvas );
var
Font: HFONT;
FontName, Txt: PChar;
sSize: Size;
i: integer;
Obj: LongWord;
begin
FontName := 'Tahoma';
Txt := 'www.decoding.dax.ru';
Font := CreateFont( 60, 30, 0, 0, FW_BOLD, 0, 0, 0, DEFAULT_CHARSET,
OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS,
PROOF_QUALITY, DEFAULT_PITCH + FF_DONTCARE, FontName );
Obj := SelectObject( Canvas.Handle, Font );
SetBkMode( Canvas.Handle, TRANSPARENT );
GetTextExtentPoint32( Canvas.Handle, Txt, Length( Txt ), sSize );
BeginPath( Canvas.Handle );
Canvas.Pen.Color:= clGreen; // Цвет текста
i := 1;
for i := 0 to 2 do // Глубина эффекта
// Позиция текста на форме
TextOut( Canvas.Handle, 5 + i, 10 + i, Txt, Length( Txt ) );
EndPath( Canvas.Handle );
// Canvas.Pen.Style := psDot; { Стиль }
StrokePath( Canvas.Handle );
SetBkMode( Canvas.Handle, OPAQUE );
DeleteObject( Obj );
DeleteObject( Font );
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
ExtFont( Canvas );
end;
|
Как перевести пиксели в миллиметры?
// Способ первый
// Имеет меньшую точность и не реагирует на изменение разрешения экрана
function PixelsToMM( WidthInPixels: Cardinal ): Extended;
begin
Result := WidthInPixels / Screen.PixelsPerInch * 25.4;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
ShowMessage( FloatToStr( PixelsToMM( 10 ) ) );
end;
// Способ второй
// Имеет меньшую точность и не реагирует на изменение разрешения экрана
procedure PixelsToMM( DC: HDC; WidthInPixels: Cardinal;
var WidthInMM, HeightInMM: Extended );
begin
WidthInMM := WidthInPixels * 25.4 / GetDeviceCaps( DC, LOGPIXELSX );
HeightInMM := WidthInPixels * 25.4 / GetDeviceCaps( DC, LOGPIXELSY );
end;
procedure TForm1.Button1Click(Sender: TObject);
var
WidthInMM, HeightInMM: Extended;
begin
PixelsToMM( GetDC( HWND( nil ) {0} ), 10, WidthInMM, HeightInMM );
ShowMessage( 'W: ' + FloatToStr( WidthInMM ) + ' H: ' + FloatToStr( HeightInMM ) );
end;
// Способ третий
// Имеет бОльшую точность
procedure PixelsToMM( DC: HDC; WidthInPixels, HeightInPixels: Cardinal;
var WidthInMM, HeightInMM: Extended );
var
HRes, VRes, HSiz, VSiz: Integer;
begin
HRes := GetDeviceCaps( DC, HORZRES );
VRes := GetDeviceCaps( DC, VERTRES );
HSiz := GetDeviceCaps( DC, HORZSIZE );
VSiz := GetDeviceCaps( DC, VERTSIZE );
WidthInMM := WidthInPixels / ( HRes / HSiz );
HeightInMM := HeightInPixels / ( VRes / VSiz );
end;
procedure TForm1.Button1Click(Sender: TObject);
var
WidthInMM, HeightInMM: Extended;
begin
PixelsToMM( GetDC( HWND( nil ) {0} ), 10, 10, WidthInMM, HeightInMM );
ShowMessage( 'W: ' + FloatToStr( WidthInMM ) + ' H: ' + FloatToStr( HeightInMM ) );
end;
|
Как перевести миллиметры в пиксели?
// Способ первый
// Имеет меньшую точность и не реагирует на изменение разрешения экрана
function MMToPixels( WidthInMM: Extended ): Cardinal;
begin
Result := Round( Screen.PixelsPerInch / 25.4 * WidthInMM );
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
ShowMessage( IntToStr( MMToPixels( 2.64583333333333 ) ) );
end;
// Способ второй
// Имеет меньшую точность и не реагирует на изменение разрешения экрана
procedure MMToPixels( DC: HDC; WidthInMM: Extended;
var WidthInPixels, HeightInPixels: Cardinal );
begin
WidthInPixels := Round( GetDeviceCaps( DC, LOGPIXELSX ) / 25.4 * WidthInMM );
HeightInPixels := Round( GetDeviceCaps( DC, LOGPIXELSY ) / 25.4 * WidthInMM );
end;
procedure TForm1.Button4Click(Sender: TObject);
var
WidthInPixels, HeightInPixels: Cardinal;
begin
MMToPixels( GetDC( HWND( nil ) {0} ), 2.64583333333333, WidthInPixels, HeightInPixels );
ShowMessage( 'W: ' + IntToStr( WidthInPixels ) + ' H: ' + IntToStr( HeightInPixels ) );
end;
// Способ третий
// Имеет бОльшую точность
procedure MMToPixels( DC: HDC; WidthInMM, HeightInMM: Extended;
var WidthInPixels, HeightInPixels: Cardinal );
var
HRes, VRes, HSiz, VSiz: Integer;
begin
HRes := GetDeviceCaps( DC, HORZRES );
VRes := GetDeviceCaps( DC, VERTRES );
HSiz := GetDeviceCaps( DC, HORZSIZE );
VSiz := GetDeviceCaps( DC, VERTSIZE );
WidthInPixels := Round( WidthInMM * ( HRes / HSiz ) );
HeightInPixels := Round( HeightInMM * ( VRes / VSiz ) );
end;
procedure TForm1.Button4Click(Sender: TObject);
var
WidthInPixels, HeightInPixels: Cardinal;
begin
MMToPixels( GetDC( HWND( nil ) {0} ), 3.52604166666667, 3.52777777777778, WidthInPixels, HeightInPixels );
ShowMessage( 'W: ' + IntToStr( WidthInPixels ) + ' H: ' + IntToStr( HeightInPixels ) );
end;
|
Как рассчитать переходный цвет между двумя исходными?
uses
Math;
const
C1: TColor = clRed;
C2: TColor = clLime;
function getNearestColor( const aColor1, aColor2: TColor; const aRate: Single ): TColor;
var
r, r1,
g, g1,
b, b1: Byte;
begin
Assert( ( aRate >= 0 ) and ( aRate <= 100 ), 'Изменение цвета должно быть меньше 100% разницы цветов' );
// Раскладываем цвета на компоненты
r := GetRValue( aColor2 );
g := GetGValue( aColor2 );
b := GetBValue( aColor2 );
r1 := GetRValue( aColor1 );
g1 := GetGValue( aColor1 );
b1 := GetBValue( aColor1 );
Result:= RGB( r1 - Floor( ( r1 - r ) * ( aRate / 100 ) ),
g1 - Floor( ( g1 - g ) * ( aRate / 100 ) ),
b1 - Floor( ( b1 - b ) * ( aRate / 100 ) ) );
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Canvas.Brush.Color := getNearestColor( C1, C2, 50 );
Canvas.FillRect( ClientRect );
end;
|
Как рассчитать последовательность переходных цветов между двумя исходными?
type
TForm1 = class(TForm)
Image1: TImage;
Image2: TImage;
Image3: TImage;
Image4: TImage;
Image5: TImage;
Image6: TImage;
Image7: TImage;
Image8: TImage;
Image9: TImage;
Image10: TImage;
procedure FormCreate(Sender: TObject);
private
GradArr: array[1..10] of TColor;
public
end;
implementation
uses
Math;
function GetColorInterval( Color1, Color2: TColor; IntervalCount, IntervalIndex: Byte ): TColor;
const
STEP = 256;
var
// Компоненты цвета
r1, r2,
g1, g2,
b1, b2: Byte;
begin
r1 := GetRValue( Color1 );
g1 := GetGValue( Color1 );
b1 := GetBValue( Color1 );
r2 := GetRValue( Color2 );
g2 := GetGValue( Color2 );
b2 := GetBValue( Color2 );
Result := RGB( Byte( Floor( r1 + ( r2 - r1 ) * Trunc( STEP / ( IntervalCount + 1 ) * IntervalIndex ) / STEP ) ),
Byte( Floor( g1 + ( g2 - g1 ) * Trunc( STEP / ( IntervalCount + 1 ) * IntervalIndex ) / STEP ) ),
Byte( Floor( b1 + ( b2 - b1 ) * Trunc( STEP / ( IntervalCount + 1 ) * IntervalIndex ) / STEP ) ) );
end;
procedure TForm1.FormCreate(Sender: TObject);
var
i: Integer;
Img: TImage;
begin
GradArr[1] := clYellow; // Начальный цвет
GradArr[10] := clRed; // Конечный цвет
for i := 1 to 8 do // Нам нужно 8 градаций
GradArr[i+1] := GetColorInterval( GradArr[1], GradArr[10], 8, i );
for i := 1 to 10 do
begin
Img := TImage( FindComponent( 'Image' + IntToStr( i ) ) );
if Assigned( Img ) then
begin
Img.Canvas.Brush.Color := GradArr[i];
Img.Canvas.FillRect( Rect( 0, 0, Img.Width, Img.Height ) );
end;
end;
end;
|
|
При использовании материала - ссылка на сайт обязательна
|
|
