htuos - Благодарю за помощь!
Я исправил ошибку в [more=вашем скрипте]
#define BeginColor 170*65536 + 148*256 + 70 ;Blue Green Red
#define FinishColor 180*65536 + 224*256 + 230
[Setup]
AppName=Gradient
AppVerName=Gradient
CreateAppDir=false
OutputDir=.
[Code]
type hDC= Longint;
var BackgroundForm: TForm; BackgroundImage: TBitmapImage; i: Integer;
function ShowWindow(hWnd, nCmdShow: LongWord): LongWord; external 'ShowWindow@user32.dll stdcall';
function GetSysColor(nIndex: Integer): DWORD; external 'GetSysColor@user32.dll stdcall';
function MulDiv(nNumber, nNumerator, nDenominator: Integer): Integer; external 'MulDiv@kernel32.dll stdcall';
function GetDC(Wnd: HWnd): hDC; external 'GetDC@user32.dll stdcall';
function ReleaseDC(Wnd: HWnd; DC: hDC): Longint; external 'ReleaseDC@user32.dll stdcall';
function SetBkMode(DC: hDC; BkMode: Integer): Integer; external 'SetBkMode@gdi32.dll stdcall';
// function BitBlt(DestDC: hDC;X,Y,Width,Height:Integer;SrcDC:HDC;XSrc,YSrc:Integer;Rop:DWORD):BOOL; external 'BitBlt@gdi32.dll stdcall';
// function SelectObject(DC: hDC; p2: LongWord): LongWord; external 'SelectObject@gdi32.dll stdcall';
// function DeleteDC(DC: hDC): BOOL; external 'DeleteDC@gdi32.dll stdcall';
Function RGB(r, g, b: Longint): Longint; Begin Result:= (r or (g shl 8) or (b shl 16)) End;
Function GetBValue(rgb: DWord): Byte; Begin Result:= Byte(rgb shr 16) End;
Function GetGValue(rgb: DWord): Byte; Begin Result:= Byte(rgb shr 8) End;
Function GetRValue(rgb: DWord): Byte; Begin Result:= Byte(rgb) End;
Procedure GradientFill(WorkBmp: TBitmapImage; BeginColor, FinishColor: TColor); var ColorBand: TRect; Begin
WorkBmp.Bitmap.Width:= WorkBmp.Width;
WorkBmp.Bitmap.Height:= WorkBmp.Height;
for i:=0 to 255 do begin
ColorBand.Right:= WorkBmp.Width;
ColorBand.Top:= MulDiv(i, WorkBmp.Height, 255);
ColorBand.Bottom:= MulDiv(i+1, WorkBmp.Height, 255);
WorkBmp.Bitmap.Canvas.Brush.Color:= RGB(GetRValue(BeginColor) + MulDiv(I, GetRValue(FinishColor) - GetRValue(BeginColor), 255-1), GetGValue(BeginColor) + MulDiv(I, GetGValue(FinishColor) - GetGValue(BeginColor), 255-1), GetBValue(BeginColor) + MulDiv(I, GetBValue(FinishColor) - GetBValue(BeginColor), 255-1));
WorkBmp.Bitmap.Canvas.FillRect(ColorBand);
end;
End;
Procedure BitmapTextOut(WorkBmp: TBitmapImage; Message, FontName: String; Style, Left, Top, Size: Byte; Color: TColor); Begin
with WorkBmp.Bitmap.Canvas do begin { позицию шрифта указывать в процентах }
Font.Color:= clBlack;
Font.Name:= FontName;
Case Style of
1: Font.Style:= [fsBold]
2: Font.Style:= [fsItalic]
3: Font.Style:= [fsBold, fsItalic]
end;
Font.Height:= (WorkBmp.Width + WorkBmp.Height)/200 *Size // попытка подстроить шрифт под размер окна
SetBkMode(Handle, 1);
TextOut(WorkBmp.Width/100*Left, WorkBmp.Height/100*Top, Message);
Font.Color:= Color;
TextOut(WorkBmp.Width/100*Left - 2, WorkBmp.Height/100*Top - 2, Message);
end
End;
Procedure BackgroundOnActivate(Sender: TObject); Begin if WizardForm.Visible then WizardForm.Show End;
Procedure BackgroundOnResize(Sender: TObject); Begin
GradientFill(BackgroundImage, {#BeginColor}, {#FinishColor});
BitmapTextOut(BackgroundImage, MainForm.Caption, 'Times', 3, 10, 8, 4, clWhite)
End;
Procedure InitializeWizard;
Begin
BackgroundForm:= TForm.Create(nil)
BackgroundForm.BorderStyle:= bsNone
BackgroundForm.OnActivate:= @BackgroundOnActivate;
BackgroundForm.OnResize:= @BackgroundOnResize;
BackgroundImage:= TBitmapImage.Create(BackgroundForm);
BackgroundImage.Align:= alClient;
BackgroundImage.Enabled:= False;
BackgroundImage.Parent:= BackgroundForm;
ShowWindow(BackgroundForm.Handle, sw_ShowMaximized) // фоновое окно на полный экран
End;
Procedure DeinitializeSetup;
Begin
BackgroundForm.Free
End;
[/more] (функция RGB), теперь градиент на битмапе рисуется правильно.
. кстати есть функции, которые позволяют считают ширину символов в пикселях (соответственно и длину теста можно получить). для моноширинных шрифтов все быстро и точно считается. так что вот с этим 