From fad535a99c59dcb7d66e17cc79e5cb365278cb36 Mon Sep 17 00:00:00 2001 From: lazarus Date: Wed, 6 Jun 2001 12:30:41 +0000 Subject: [PATCH] MG: bugfixes git-svn-id: trunk@286 - --- ide/main.pp | 6 +- lcl/buttons.pp | 5 +- lcl/dialogs.pp | 5 +- lcl/include/bitbtn.inc | 35 ++-- lcl/include/buttonglyph.inc | 39 ++-- lcl/include/buttons.inc | 14 +- lcl/include/messagedialogs.inc | 342 +++++++++++++++++++------------ lcl/include/pixmap.inc | 50 ++--- lcl/interfaces/gtk/gtkwinapi.inc | 78 ++++--- 9 files changed, 334 insertions(+), 240 deletions(-) diff --git a/ide/main.pp b/ide/main.pp index 6bfd5555fa..e2ef9037e8 100644 --- a/ide/main.pp +++ b/ide/main.pp @@ -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 diff --git a/lcl/buttons.pp b/lcl/buttons.pp index 4372cc53d2..0e63bd18a3 100644 --- a/lcl/buttons.pp +++ b/lcl/buttons.pp @@ -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 diff --git a/lcl/dialogs.pp b/lcl/dialogs.pp index 3af32b971f..d267d543fe 100644 --- a/lcl/dialogs.pp +++ b/lcl/dialogs.pp @@ -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 diff --git a/lcl/include/bitbtn.inc b/lcl/include/bitbtn.inc index d6f888ade8..419173671f 100644 --- a/lcl/include/bitbtn.inc +++ b/lcl/include/bitbtn.inc @@ -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); diff --git a/lcl/include/buttonglyph.inc b/lcl/include/buttonglyph.inc index 6d18c841f2..c4f3da0430 100644 --- a/lcl/include/buttonglyph.inc +++ b/lcl/include/buttonglyph.inc @@ -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; diff --git a/lcl/include/buttons.inc b/lcl/include/buttons.inc index 0f8473e14e..59c7b5ef64 100644 --- a/lcl/include/buttons.inc +++ b/lcl/include/buttons.inc @@ -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) diff --git a/lcl/include/messagedialogs.inc b/lcl/include/messagedialogs.inc index ac9f237caa..0423814279 100644 --- a/lcl/include/messagedialogs.inc +++ b/lcl/include/messagedialogs.inc @@ -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) diff --git a/lcl/include/pixmap.inc b/lcl/include/pixmap.inc index 41d50e3bda..5290b14299 100644 --- a/lcl/include/pixmap.inc +++ b/lcl/include/pixmap.inc @@ -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 diff --git a/lcl/interfaces/gtk/gtkwinapi.inc b/lcl/interfaces/gtk/gtkwinapi.inc index f1680d6d21..6178067dc6 100644 --- a/lcl/interfaces/gtk/gtkwinapi.inc +++ b/lcl/interfaces/gtk/gtkwinapi.inc @@ -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