paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-09-02 01:00:22 +02:00
Code Issues Packages Projects Releases Wiki Activity

MG: bugfixes

Browse Source 
git-svn-id: trunk@286 -
This commit is contained in:
lazarus 2001-06-06 12:30:41 +00:00
parent 83614914dc
commit fad535a99c
9 changed files with 334 additions and 240 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
ide/main.pp
View File

@ -1187,7 +1187,7 @@ procedure TMainIDE.mnuOpenClicked(Sender : TObject);
var OpenDialog:TOpenDialog;
AFilename: string;
begin
if Sender=itmFileOpen then begin
if (Sender=itmFileOpen) or (Sender=OpenFileSpeedBtn) then begin
OpenDialog:=TOpenDialog.Create(Application);
try
OpenDialog.Title:='Open file';
@ -3453,8 +3453,8 @@ end.
{ =============================================================================
$Log$
Revision 1.101 2001/06/05 16:48:18 lazarus
MG: added recent file sub menus
Revision 1.102 2001/06/06 12:30:40 lazarus
MG: bugfixes
Revision 1.100 2001/06/05 10:27:50 lazarus
MG: saving recent file lists

5
lcl/buttons.pp
View File

@ -24,7 +24,7 @@
unit Buttons;
{$mode objfpc}
{$mode objfpc}{$H+}
interface
@ -235,6 +235,9 @@ end.
{ =============================================================================
$Log$
Revision 1.8 2001/06/06 12:30:41 lazarus
MG: bugfixes
Revision 1.7 2001/01/09 21:06:06 lazarus
Started taking KeyDown messages in TDesigner
Shane

5
lcl/dialogs.pp
View File

@ -29,7 +29,7 @@ Detailed description of the Unit.
unit dialogs;
{$mode objfpc}
{$mode objfpc}{$H+}
interface
@ -203,6 +203,9 @@ end.
{ =============================================================================
$Log$
Revision 1.6 2001/06/06 12:30:41 lazarus
MG: bugfixes
Revision 1.5 2001/03/27 11:11:13 lazarus
MG: fixed mouse msg, added filedialog initialdir

35
lcl/include/bitbtn.inc
View File

@ -25,39 +25,38 @@ Begin
inherited Destroy;
end;
Procedure TBitBtn.Click;
var
Form : TCustomForm;
Form : TCustomForm;
Begin
if FKind = bkClose then
Begin
Form := GetParentForm(Self);
if Form <> nil then Form.Close
else
inherited click;
end
else
inherited Click;
if FKind = bkClose then Begin
Form := GetParentForm(Self);
if Form <> nil then Form.Close
else
inherited click;
end
else
inherited Click;
End;
Function TBitbtn.GetGlyph : TBitmap;
Begin
Result := TButtonGlyph(FGlyph).Glyph;
Result := TButtonGlyph(FGlyph).Glyph;
end;
Function TBitBtn.IsCustom : Boolean;
Begin
Result := Kind = bkCustom;
Result := Kind = bkCustom;
end;
Procedure TBitbtn.SetGlyph(Value : TBitmap);
Begin
Assert(False, 'Trace:SETGLYPH');
TButtonGlyph(FGlyph).Glyph := Value;
CNSendMessage(LM_IMAGECHANGED,Self,nil);
Invalidate;
Assert(False, 'Trace:SETGLYPH');
TButtonGlyph(FGlyph).Glyph := Value;
if HandleAllocated then begin
CNSendMessage(LM_IMAGECHANGED,Self,nil);
Invalidate;
end;
end;
Procedure TBitBtn.SetKind(Value : TBitBtnKind);

39
lcl/include/buttonglyph.inc
View File

@ -31,36 +31,39 @@ end;
{------------------------------------------------------------------------------}
{ TButtonGlyph Draw }
{------------------------------------------------------------------------------}
Function TButtonGlyph.Draw(Canvas: TCanvas; const Client: TRect; const Offset: TPoint;
const Caption: string; Layout: TButtonLayout; Margin, Spacing: Integer;
State: TButtonState; Transparent: Boolean; BiDiFlags: Longint): TRect;
Function TButtonGlyph.Draw(Canvas: TCanvas; const Client: TRect;
const Offset: TPoint; const Caption: string; Layout: TButtonLayout;
Margin, Spacing: Integer; State: TButtonState; Transparent: Boolean;
BiDiFlags: Longint): TRect;
var
gWidth : integer;
gHeight : integer;
gWidth : integer;
gHeight : integer;
begin
// for default assume only 1 glyph
// for default assume only 1 glyph
gWidth := TPixMap(FOriginal).Width;
gHeight := TPixMap(FOriginal).Height;
Result := Rect(0, 0, gWidth - 1, gHeight - 1);
gWidth := TPixMap(FOriginal).Width;
gHeight := TPixMap(FOriginal).Height;
Result := Rect(0, 0, gWidth - 1, gHeight - 1);
if NumGlyphs > 1 then
begin
if NumGlyphs > 1 then
begin
gWidth := TPixMap(FOriginal).Width div NumGlyphs;
if (State = bsDown) and (NumGlyphs < 3) then
State := bsUp;
State := bsUp;
if State = bsDisabled then
Result := Rect(gWidth, 0, (2 * gWidth) - 1, gHeight - 1)
Result := Rect(gWidth, 0, (2 * gWidth) - 1, gHeight - 1)
else if State = bsDown then
Result := Rect(2 * gWidth, 0, (3 * gWidth) - 1, gHeight - 1)
Result := Rect(2 * gWidth, 0, (3 * gWidth) - 1, gHeight - 1)
else
Result := Rect(0, 0, gWidth - 1, gHeight - 1);
end;
Result := Rect(0, 0, gWidth - 1, gHeight - 1);
end;
Canvas.Copyrect(Client, TPixmap(FOriginal).Canvas, Result);
if not Transparent then
Canvas.Copyrect(Client, TPixmap(FOriginal).Canvas, Result)
else
;
end;

14
lcl/include/buttons.inc
View File

@ -8,19 +8,13 @@
constructor TButton.Create(AOwner: TComponent);
begin
Inherited Create(AOwner);
{set the component style to csButton}
fCompStyle := csButton;
{set default alignment}
Align := alNone;
{setup default sizes}
SetBounds(1, 1, 50, 25);
SetBounds(1, 1, 75, 25);
end;
{------------------------------------------------------------------------------
@ -47,7 +41,8 @@ begin
if FDefault = Value then Exit;
FDefault := Value;
CNSendMessage(LM_BTNDEFAULT_CHANGED,Self,nil);
if HandleAllocated then
CNSendMessage(LM_BTNDEFAULT_CHANGED,Self,nil);
End;
{------------------------------------------------------------------------------
@ -102,6 +97,9 @@ end;
{ =============================================================================
$Log$
Revision 1.3 2001/06/06 12:30:41 lazarus
MG: bugfixes
Revision 1.2 2000/07/16 12:37:52 lazarus
Added OnMouseEnter, OnMouseLeave property
(code from christer, added by stoppok)

342
lcl/include/messagedialogs.inc
View File

@ -37,9 +37,12 @@ type
FLabel : TLabel;
FDlgType : TMsgDlgType;
FButtons : TMsgDlgButtons;
FRelayoutNeeded: boolean;
FUpdateCounter: integer;
procedure SetText (const value : string);
procedure SetDialogType (const value : TMsgDlgType);
procedure SetButtons (const value : TMsgDlgButtons);
procedure ReLayout;
public
constructor Create (AOwner : TComponent); override;
destructor Destroy; override;
@ -47,6 +50,8 @@ type
property TheMessage : string write SetText;
property DialogType : TMsgDlgType write SetDialogType;
property Buttons : TMsgDlgButtons write SetButtons;
procedure BeginUpdate;
procedure EndUpdate;
end;
const
@ -60,8 +65,8 @@ const
cBitmapWidth = 32; // width of the dialogs icon
cBitmapHeight= 32; // height of the dialogs icon
cLabelSpacing= 10; // distance between icon & label
cLabelHeight = 40; // height of the (multiline) label
cLabelWidth = 130; // width of the label
cLabelHeight = 40; // default height of the (multiline) label
cLabelWidth = 130; // default width of the label
{------------------------------------------------------------------------------
Method: TMessageBox.Create
@ -72,16 +77,31 @@ const
------------------------------------------------------------------------------}
constructor TMessageBox.Create (AOwner : TComponent);
begin
inherited Create (AOwner);
inherited Create (AOwner);
BorderStyle := bsDialog;
Position := poMainFormCenter;
width := 200;
height := 100;
FDlgType := mtInformation;
Caption := cMtCaption [FDlgType];
FBitmap := nil;
FLabel := nil;
BorderStyle := bsDialog;
Position := poScreenCenter;
Width := 200;
Height := 100;
FDlgType := mtInformation;
Caption := cMtCaption[FDlgType];
FBitmap := nil;
FButtons := [];
FRelayoutNeeded := false;
FUpdateCounter := 0;
FLabel := TLabel.Create(self);
with FLabel do begin
Name := 'FLabel';
Parent := self;
Font.Size := 5;
Top := 10;
Left := cBitmapX + cBitmapWidth + cLabelSpacing;
Height := cLabelHeight;
Width := cLabelWidth;
WordWrap := true;
Visible := true;
end;
end;
{------------------------------------------------------------------------------
@ -93,8 +113,8 @@ end;
------------------------------------------------------------------------------}
destructor TMessageBox.Destroy;
begin
FBitmap.Free;
inherited Destroy;
FBitmap.Free;
inherited Destroy;
end;
{------------------------------------------------------------------------------
@ -106,11 +126,17 @@ end;
------------------------------------------------------------------------------}
procedure TMessageBox.Paint;
begin
inherited Paint;
//TODO: use real with of the icon (Currently FBitmap.Width /Height are always 0, seems to be a bug somewhere)
if assigned (FBitmap)
then Canvas.Copyrect(Bounds(cBitmapX, cBitmapY, cBitmapWidth{FBitmap.width+1}, cBitmapHeight{FBitmap.Height+1}),
FBitmap.Canvas, Rect(0,0, FBitmap.Width, FBitmap.Height));
inherited Paint;
//TODO: use real width of the icon (Currently FBitmap.Width /Height are always 0,
//seems to be a bug somewhere)
if assigned (FBitmap) then
Canvas.CopyRect(Bounds(cBitmapX, cBitmapY,
cBitmapWidth{FBitmap.width+1},
cBitmapHeight{FBitmap.Height+1}),
FBitmap.Canvas,
Rect(0,0,
cBitmapWidth{FBitmap.width+1},
cBitmapHeight{FBitmap.Height+1}));
end;
{------------------------------------------------------------------------------
@ -118,23 +144,45 @@ end;
Params: value - text to be displayed in the message box
Returns: Nothing
Creates a label to display the text.
Sets the Text in MessageBox
Cuts long lines in shorter ones and resizes the label
------------------------------------------------------------------------------}
procedure TMessageBox.SetText (const value : string);
procedure TMessageBox.SetText (const Value : string);
var TheText: string;
i, LineStart, LineWidth, LineCount: integer;
FTextHeight: integer;
FTextWidth: integer;
begin
if not (assigned (FLabel)) then
begin
FLabel := TLabel.Create(self);
FLabel.Parent := self;
FLabel.Font.Size := 5;
FLabel.top := 10;
FLabel.left := cBitmapX + cBitmapWidth + cLabelSpacing;
FLabel.Height := cLabelHeight;
FLabel.Width := cLabelWidth;
FLabel.WordWrap := true;
end;
FLabel.Show;
FLabel.Caption := value;
// TODO: use Font to calculate TextWidth
LineCount:=1;
FTextWidth:=0;
i:=1;
LineStart:=i;
TheText:=Value;
while i<=length(TheText) do begin
if TheText[i]=#13 then begin
LineWidth:=8*length(copy(TheText,LineStart,i-LineStart));
if LineWidth>FTextWidth then FTextWidth:=LineWidth;
inc(LineCount);
while (i<=length(TheText)) and (TheText[i] in [#10,#13,#0]) do
inc(i);
LineStart:=i;
end else if i-LineStart>=80 then begin
LineWidth:=8*length(copy(TheText,LineStart,i-LineStart));
if LineWidth>FTextWidth then FTextWidth:=LineWidth;
inc(LineCount);
LineStart:=i;
end;
inc(i);
end;
if LineCount=1 then
FTextWidth:=8*length(TheText);
FTextHeight:=LineCount*25;
FLabel.Caption := TheText;
FLabel.Width:=FTextWidth;
FLabel.Height:=FTextHeight;
FRelayoutNeeded:=true;
ReLayout;
end;
{------------------------------------------------------------------------------
@ -146,12 +194,13 @@ end;
------------------------------------------------------------------------------}
procedure TMessageBox.SetDialogType (const value : TMsgDlgType);
begin
if (value = FDlgType) and (assigned (FBitmap)) then exit;
FDlgType := value;
FBitmap.Free;
FBitmap := TBitmap.Create;
FBitmap.Handle := CreatePixmapIndirect(@mtImages[FDlgType], ColorToRGB(clBtnFace));
Caption := cMtCaption [FDlgType];
if (value = FDlgType) and (assigned (FBitmap)) then exit;
FDlgType := value;
FBitmap.Free;
FBitmap := TBitmap.Create;
FBitmap.Handle := CreatePixmapIndirect(@mtImages[FDlgType],
ColorToRGB(clBtnFace));
Caption := cMtCaption[FDlgType];
end;
{------------------------------------------------------------------------------
@ -162,134 +211,161 @@ end;
Depending on "value" this method inserts some buttons into the dialog.
The more buttons required, the wider the dialog will be.
------------------------------------------------------------------------------}
procedure TMessageBox.SetButtons (const value : TMsgDlgButtons);
const
cBtnWidth = 85; //TODO: Take into account different languages; button width may vary!
cBtnDist = cBtnWidth + 25;
cBtnHeight = 32;
cMinLeft = cBtnDist - cBtnWidth;
var
aButton : TBitBtn; // temp. variable to create buttons
aBitmap : TBitmap; // temp. variable to create bitmaps for buttons
curBtn : TMsgDlgBtn; // variable to loop through TMsgDlgButtons
ButtonLeft : integer; // left position of button(s)
LabelLeft : integer; // left position of label
reqBWidth : integer; // width neccessary to display all buttons
reqLWidth : integer; // width neccessary to display the label
procedure TMessageBox.SetButtons(const value : TMsgDlgButtons);
begin
FButtons := value;
// calculate the width we need to display the buttons
reqBWidth := cMinLeft;
curBtn := low (TMsgDlgBtn);
while curBtn < high (TMsgDlgBtn) do
begin
if curBtn in FButtons then reqBWidth := reqBWidth + cBtnDist;
inc (curBtn);
end;
//TODO: calculate the width we need for the label
reqLWidth := 200;
// set size of form
// patch positions to center label and buttons
if reqBWidth >= reqLWidth then
begin
width := reqBWidth;
LabelLeft := round ((width - reqLWidth) / 2);
ButtonLeft := cMinLeft;
end
else begin
width := reqLWidth;
ButtonLeft := round ((width - reqBWidth + 2*cMinLeft) / 2);
writeln ('ButtonLeft :', ButtonLeft, ' RequestedWidth : ',reqBWidth, 'Formwidth : ', width);
LabelLeft := cMinLeft + 4*FBitmap.Width;
end;
// FLabel.left := LabelLeft;
// create the buttons
// ButtonLeft := cMinLeft;
curBtn := low (TMsgDlgBtn);
//Todo -cmaybe 4:clear any buttons (only for general purpose use)!!!
while curBtn < high (TMsgDlgBtn) do
begin
if curBtn in value then
begin
aButton := TBitBtn.Create(self);
With aButton do
begin
Parent := self;
SetBounds (ButtonLeft, 60, cBtnWidth, cBtnHeight);
ButtonLeft := ButtonLeft + cBtnDist;
layout := blGlyphLeft;
aBitmap := TBitmap.Create;
aBitmap.Handle := CreatePixmapIndirect(@mbImages [curBtn], ColorToRGB(clBtnFace));
Glyph := aBitmap;
ModalResult := cMbResult [curBtn];
caption := cMbCaption [curBtn];
if curbtn in [mbOK, mbYes] then Default := true;
Show;
end;
end;
inc (curBtn);
end;
if FButtons = Value then exit;
FButtons := Value;
FRelayoutNeeded:=true;
ReLayout;
end;
procedure TMessageBox.ReLayout;
const
cBtnWidth = 85; //TODO: Take into account different languages; button width may vary!
cBtnDist = cBtnWidth + 25;
cBtnHeight = 32;
cMinLeft = cBitmapX + cBitmapWidth + cLabelSpacing;
var
aButton : TBitBtn; // temp. variable to create buttons
aBitmap : TBitmap; // temp. variable to create bitmaps for buttons
curBtn : TMsgDlgBtn; // variable to loop through TMsgDlgButtons
ButtonLeft : integer; // left position of button(s)
LabelLeft : integer; // left position of label
reqBtnWidth : integer; // width neccessary to display buttons
reqWidth : integer; // width neccessary to display all
reqHeight : integer; // height neccessary to display all
i: integer;
begin
if FUpdateCounter>0 then exit;
// destroy old BitBtns
for i:=ComponentCount-1 downto 0 do
if Components[i] is TBitBtn then
Components[i].Free;
// calculate the width we need to display the buttons
reqBtnWidth := 0;
for curBtn := low (TMsgDlgBtn) to high (TMsgDlgBtn) do
if curBtn in FButtons then inc(reqBtnWidth, cBtnDist);
// patch positions to center label and buttons
if reqWidth < FLabel.Width then reqWidth:=FLabel.Width;
LabelLeft := ((reqWidth - FLabel.Width) div 2) + cMinLeft;
ButtonLeft := ((reqWidth - reqBtnWidth) div 2) + cMinLeft;
// set size of form
SetBounds(Left,Top,reqWidth+cMinLeft+cLabelSpacing,
4*cLabelSpacing+FLabel.Height+cBtnHeight);
// position the label
FLabel.Left := LabelLeft;
// create the buttons
for curBtn := low(TMsgDlgBtn) to high(TMsgDlgBtn) do begin
if curBtn in FButtons then begin
aButton := TBitBtn.Create(self);
With aButton do begin
Parent := Self;
SetBounds (ButtonLeft, 3*cLabelSpacing+FLabel.Height
, cBtnWidth, cBtnHeight);
inc(ButtonLeft, cBtnDist);
layout := blGlyphLeft;
// ToDo: when TBitmap streaming is working, load image from resource
aBitmap := TBitmap.Create;
aBitmap.Handle := CreatePixmapIndirect(@mbImages [curBtn],
ColorToRGB(clBtnFace));
Glyph := aBitmap;
ModalResult := cMbResult[curBtn];
Caption := cMbCaption[curBtn];
if curbtn in [mbOK, mbYes] then Default := true;
Visible:=true;
end;
end;
end;
FRelayoutNeeded:=false;
end;
procedure TMessageBox.BeginUpdate;
begin
inc(FUpdateCounter);
end;
procedure TMessageBox.EndUpdate;
begin
dec(FUpdateCounter);
if FUpdateCounter<0 then FUpdateCounter:=0;
if (FUpdateCounter=0) and (FRelayoutNeeded) then
ReLayout;
end;
// ---------------------------------------------------------------------------
function CreateMessageDialog(const aMsg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons): TForm;
function CreateMessageDialog(const aMsg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons): TForm;
var
msgbox : TMessageBox;
msgbox : TMessageBox;
begin
msgbox := TMessageBox.Create (application);
msgbox.theMessage := aMsg;
msgBox.DialogType := DlgType;
msgBox.Buttons := buttons;
result := msgbox;
msgbox := TMessageBox.Create (application);
msgbox.BeginUpdate;
msgbox.theMessage := aMsg;
msgBox.DialogType := DlgType;
msgBox.Buttons := buttons;
msgbox.EndUpdate;
Result := msgbox;
end;
function MessageDlg(const aMsg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer;
function MessageDlg(const aMsg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; HelpCtx: Longint): Integer;
var
aDialog : TForm;
aDialog : TForm;
begin
aDialog := CreateMessageDialog (aMsg, DlgType, buttons);
result := aDialog.ShowModal;
aDialog.Free;
aDialog := CreateMessageDialog (aMsg, DlgType, buttons);
Result := aDialog.ShowModal;
aDialog.Free;
end;
function MessageDlgPos(const aMsg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer;
function MessageDlgPos(const aMsg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer): Integer;
var
aDialog : TForm;
begin
writeln ('****** NOT YET FULLY IMPLEMENTED ********');
//TODO: set helpcontext and x/y coordinates
result := MessageDlg (aMsg, DlgType, buttons, helpctx);
writeln ('MessageDlgPos ****** NOT YET FULLY IMPLEMENTED ********');
aDialog := CreateMessageDialog (aMsg, DlgType, buttons);
aDialog.Left := x;
aDialog.Top := y;
Result := aDialog.ShowModal;
end;
function MessageDlgPosHelp(const aMsg: string; DlgType: TMsgDlgType; Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer; const HelpFileName: string): Integer;
function MessageDlgPosHelp(const aMsg: string; DlgType: TMsgDlgType;
Buttons: TMsgDlgButtons; HelpCtx: Longint; X, Y: Integer;
const HelpFileName: string): Integer;
begin
writeln ('****** NOT YET FULLY IMPLEMENTED ********');
writeln ('MessageDlgPosHelp ****** NOT YET FULLY IMPLEMENTED ********');
//TODO: set helpcontext and helpfile
result := MessageDlg (aMsg, DlgType, buttons, helpctx);
result := MessageDlg (aMsg, DlgType, buttons, helpctx);
end;
procedure ShowMessage(const aMsg: string);
begin
MessageDlg (aMsg, mtInformation, [mbOK], 0);
MessageDlg (aMsg, mtInformation, [mbOK], 0);
end;
procedure ShowMessageFmt(const aMsg: string; Params: array of const);
begin
MessageDlg (Format (aMsg, Params), mtInformation, [mbOK], 0);
MessageDlg (Format (aMsg, Params), mtInformation, [mbOK], 0);
end;
procedure ShowMessagePos(const aMsg: string; X, Y: Integer);
begin
writeln ('****** NOT YET FULLY IMPLEMENTED ********');
MessageDlg (aMsg, mtInformation, [mbOK], 0);
writeln ('ShowMessagePos ****** NOT YET FULLY IMPLEMENTED ********');
MessageDlg (aMsg, mtInformation, [mbOK], 0);
end;
{
$Log$
Revision 1.2 2001/06/06 12:30:41 lazarus
MG: bugfixes
Revision 1.1 2001/03/03 00:50:34 lazarus
+ added support for message dialogs (messagedialogs.inc)
+ added some pixmaps for message dialogs(messagedialogpixmaps.inc)

50
lcl/include/pixmap.inc
View File

@ -25,7 +25,7 @@ begin
FreeContext;
// Convert a XPM filedata format to a XPM memory format
// by filling an array of PChar whith the contents between
// by filling an array of PChar with the contents between
// the ""'s in the file
S := TStringList.Create;
@ -35,34 +35,33 @@ begin
BufPtr := Pointer(Buf);
try
for n := 0 to S.Count - 1 do
if S.Strings[n][1] = '"'
then begin
//Debug info
p := @S.Strings[n][2];
//---
BufPtr^ := @S.Strings[n][2];
P := StrScan(BufPtr^, '"');
if p <> nil then p^ := #0;
Inc(BufPtr);
end;
if FTransparentColor = clNone
then Handle := CreatePixmapIndirect(Buf, -1)
else Handle := CreatePixmapIndirect(Buf, ColorToRGB(FTransparentColor));
if (S[n]<>'') and (S[n][1] = '"') then begin
BufPtr^ := @S[n][2];
P := StrScan(BufPtr^, '"');
if p <> nil then p^ := #0;
Inc(BufPtr);
end;
if FTransparentColor = clNone then
// create an transparent pixmap (with mask)
Handle := CreatePixmapIndirect(Buf, -1)
else
// create an opaque pixmap.
// Transparent pixels are filled with FTransparentColor
Handle := CreatePixmapIndirect(Buf, ColorToRGB(FTransparentColor));
//set width and height
try
t := S.Strings[2]; //this line contains the width and height
t := S[2]; //this line contains the width and height
//remove the initial quote
delete(t,1,1);
Delete(t,pos(' ',t),length(t));
Width := strtoint(t);
System.Delete(t,1,1);
System.Delete(t,pos(' ',t),length(t));
FWidth := StrToIntDef(t,1);
t := S.Strings[2]; //this line contains the width and height
delete(t,1,1);
Delete(t,1,pos(' ',t));
Delete(t,pos(' ',t),length(t));
Height := strtoint(t);
t := S[2]; //this line contains the width and height
System.Delete(t,1,1);
System.Delete(t,1,pos(' ',t));
System.Delete(t,pos(' ',t),length(t));
FHeight := StrToIntDef(t,1);
except
end;
@ -77,6 +76,9 @@ end;
{ =============================================================================
$Log$
Revision 1.9 2001/06/06 12:30:41 lazarus
MG: bugfixes
Revision 1.8 2001/03/19 14:40:49 lazarus
MG: fixed many unreleased DC and GDIObj bugs

78
lcl/interfaces/gtk/gtkwinapi.inc
View File

@ -757,7 +757,8 @@ end;
Creates a bitmap from raw pixmap data.
------------------------------------------------------------------------------}
function TgtkObject.CreatePixmapIndirect(const Data: Pointer; const TransColor: Longint): HBITMAP;
function TgtkObject.CreatePixmapIndirect(const Data: Pointer;
const TransColor: Longint): HBITMAP;
var
GdiObject: PGdiObject;
GDKColor: TGDKCOlor;
@ -771,7 +772,8 @@ begin
p := @GDKColor;
end
else p := nil;
GdiObject^.GDIBitmapObject := gdk_pixmap_colormap_create_from_xpm_d(nil, gdk_colormap_get_system, @(GdiObject^.GDIBitmapMaskObject), p, data);
GdiObject^.GDIBitmapObject := gdk_pixmap_colormap_create_from_xpm_d(nil,
gdk_colormap_get_system, @(GdiObject^.GDIBitmapMaskObject), p, data);
Result := HBITMAP(GdiObject);
end;
@ -2227,25 +2229,25 @@ end;
------------------------------------------------------------------------------}
function TGTKObject.KillTimer (hWnd : HWND; uIDEvent : cardinal) : boolean;
var
n : integer;
p : PGtkITimerinfo;
n : integer;
p : PGtkITimerinfo;
begin
Assert(False, 'Trace:removing timer!!!');
n := FTimerData.Count;
while (n > 0) do
begin
dec (n);
p := PGtkITimerinfo (FTimerData.Items[n]);
if ((pointer (hWnd) <> nil) and (hWnd = p^.Handle)) or
((pointer(hWnd) = nil) and (uIDEvent = p^.IDEvent)) then
begin
gtk_timeout_remove (uIDEvent);
FTimerData.Delete (n);
pointer (p^.Handle) := nil; // mark as invalid
p^.TimerFunc := nil;
// Dispose (p); // this will be done in gtkTimerCB!
end;
end;
Assert(False, 'Trace:removing timer!!!');
n := FTimerData.Count;
while (n > 0) do begin
dec (n);
p := PGtkITimerinfo (FTimerData.Items[n]);
if ((pointer (hWnd) <> nil) and (hWnd = p^.Handle)) or
((pointer(hWnd) = nil) and (uIDEvent = p^.IDEvent)) then
begin
gtk_timeout_remove (uIDEvent);
FTimerData.Delete (n);
pointer (p^.Handle) := nil; // mark as invalid
p^.TimerFunc := nil;
// Dispose (p); // this will be done in gtkTimerCB!
end;
end;
Result:=true;
end;
{------------------------------------------------------------------------------
@ -3405,30 +3407,34 @@ end;
Sizing is done according to the stretching mode currently set in the
destination device context.
------------------------------------------------------------------------------}
function TgtkObject.StretchBlt(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer; Rop: Cardinal): Boolean;
function TgtkObject.StretchBlt(DestDC: HDC; X, Y, Width, Height: Integer;
SrcDC: HDC; XSrc, YSrc, SrcWidth, SrcHeight: Integer; Rop: Cardinal): Boolean;
var
pixmap : PgdkPixmap;
pixmapwid : pgtkWidget;
begin
Assert(True, Format('trace:> [TgtkObject.StretchBlt] DestDC:0x%x; X:%d, Y:%d, Width:%d, Height:%d; SrcDC:0x%x; XSrc:%d, YSrc:%d, SrcWidth:%d, SrcHeight:%d; Rop:0x%x', [DestDC, X, Y, Width, Height, SrcDC, XSrc, YSrc, SrcWidth, SrcHeight, Rop]));
Result := IsValidDC(DestDC) and IsValidDC(SrcDC);
if Result
then begin
if Result then begin
gdk_gc_set_function(PDeviceContext(DestDC)^.GC, GDK_COPY);
// TODO: Add scaling and ROP
//first create a pixmap with transparency
{ THIS is test code for transparency
pixmap := pgdkPixmap(PgdiObject(Srcdc)^.GDIBitmapObject);
if PgdiObject(SRCdc)^.GDIBitmapMaskObject <> nil then
pixmapwid := gtk_pixmap_new(pixmap,PgdiObject(SRCdc)^.GDIBitmapMAskObject);
gdk_draw_pixmap(PDeviceContext(DestDC)^.Drawable, PDeviceContext(DestDC)^.GC, PgdkDrawable(pixmapwid^.window),
XSrc, YSrc, X, Y, SrcWidth, SrcHeight);
}
gdk_draw_pixmap(PDeviceContext(DestDC)^.Drawable, PDeviceContext(DestDC)^.GC, PDeviceContext(SrcDC)^.Drawable,
XSrc, YSrc, X, Y, SrcWidth, SrcHeight);
if PgdiObject(SRCdc)^.GDIBitmapMaskObject <> nil then begin
// THIS is test code for transparency
{ pixmap := pgdkPixmap(PgdiObject(Srcdc)^.GDIBitmapObject);
pixmapwid := gtk_pixmap_new(pixmap,PgdiObject(SRCdc)^.GDIBitmapMAskObject);
gdk_draw_pixmap(PDeviceContext(DestDC)^.Drawable,PDeviceContext(DestDC)^.GC,
PgdkDrawable(pixmapwid^.window),
XSrc, YSrc, X, Y, SrcWidth, SrcHeight);}
gdk_draw_pixmap(PDeviceContext(DestDC)^.Drawable,
PDeviceContext(SrcDC)^.GC, PDeviceContext(SrcDC)^.Drawable,
XSrc, YSrc, X, Y, SrcWidth, SrcHeight);
end else begin
gdk_draw_pixmap(PDeviceContext(DestDC)^.Drawable,
PDeviceContext(DestDC)^.GC, PDeviceContext(SrcDC)^.Drawable,
XSrc, YSrc, X, Y, SrcWidth, SrcHeight);
end;
end;
Assert(True, Format('trace:< [TgtkObject.StretchBlt] DestDC:0x%x --> %s', [DestDC, BOOL_TEXT[Result]]));
end;
@ -3514,7 +3520,11 @@ end;
{ =============================================================================
$Log$
Revision 1.34 2001/06/06 12:30:41 lazarus
MG: bugfixes
Revision 1.33 2001/04/13 13:22:23 lazarus
Made fix to buttonglyph to use the correct size of single glyph
Made fix to StretchBlt to use the correct height and width
Both of these corrected the Win32 Speedbutton problem MAH