journer.htm

关于DEPHI7.0的网络聊天信息管理系统源代码

      <p> Align:=alClient;<br>
        FMoveForm:=true;<br>
        FPicture :=TBitMap.Create;<br>
        FPicture.OnChange:=PictureChange;<br>
        end;</p>
      <p>destructor TImgForm.Destroy;<br>
        begin<br>
        FPicture.Free;<br>
        inherited Destroy;<br>
        end;</p>
      <p>procedure TImgForm.paint;<br>
        const<br>
        XorColor = $00FFD8CE;<br>
        begin<br>
        with Canvas do begin<br>
        if (csDesigning in ComponentState) then begin<br>
        Pen.Style := psDot;<br>
        Pen.Mode := pmXor;<br>
        Pen.Color := XorColor;<br>
        Brush.Style := bsClear;<br>
        Rectangle(0, 0, ClientWidth, ClientHeight);<br>
        TextOut(5,5,'ImgForm');<br>
        moveto(0,0);<br>
        Lineto(Width,height);<br>
        moveto(0,Height);<br>
        Lineto(Width,0);<br>
        end;<br>
        <br>
        if not FPicture.Empty then<br>
        Draw(0,0,FPicture);<br>
        end;<br>
        // inherited Paint; // 如果控件从TGraphicControl继承，就不要注释这里<br>
        end;</p>
      <p>procedure TImgForm.PictureChange(Sender: TObject);<br>
        begin<br>
        if not FPicture.Empty then begin<br>
        Align:=alNone;<br>
        Width:=FPicture.Width;<br>
        Height:=FPicture.Height;<br>
        end<br>
        else<br>
        Align:=alClient;<br>
        end;</p>
      <p>procedure TImgForm.Execute;<br>
        var<br>
        h,w,i,j:integer;<br>
        tc:Tcolor;<br>
        hrgn1,hrgn3:HRGN;<br>
        begin<br>
        if not FPicture.Empty then begin<br>
        tc:=FPicture.Canvas.Pixels[0,0];<br>
        h:=FPicture.Canvas.ClipRect.Bottom -FPicture.Canvas.ClipRect.top ;<br>
        w:=FPicture.Canvas.ClipRect.Right -FPicture.Canvas.ClipRect.left ;<br>
        hrgn3:=createrectrgn(0,0,w,h);<br>
        try<br>
        for i:=0 to w-1 do<br>
        for j:=0 to h-1 do<br>
        begin<br>
        if FPicture.Canvas.Pixels[i,j]=tc then<br>
        begin<br>
        deleteobject(hrgn1);<br>
        hrgn1:=CreateRectRgn(i,j,i+1,j+1);<br>
        if hrgn1&lt;&gt;0 then<br>
        begin<br>
        CombineRgn(hrgn3,hrgn3,hrgn1,RGN_DIFF);<br>
        end;<br>
        end;<br>
        end;<br>
        deleteobject(hrgn1);<br>
        setwindowrgn(FormHandle,hrgn3,true);<br>
        except<br>
        //RaiseException Here<br>
        end;<br>
        end;<br>
        end;</p>
      <p>procedure TImgForm.SetPicture(Value: TBitMap);<br>
        begin<br>
        FPicture.Assign(Value);<br>
        Invalidate;<br>
        end;</p>
      <p>procedure TImgForm.MouseMove(Shift: TShiftState; X,<br>
        Y: Integer);<br>
        begin<br>
        inherited;<br>
        if FMoveForm then begin<br>
        ReleaseCapture;<br>
        (Parent as TForm).perform(WM_SysCommand, $F012, 0);<br>
        end;<br>
        end;</p>
      <p>procedure TImgForm.HideInTaskBar;<br>
        var<br>
        ExtendedStyle : Integer;<br>
        begin<br>
        ExtendedStyle := GetWindowLong (Application.Handle, GWL_EXSTYLE);<br>
        SetWindowLong(Application.Handle, GWL_EXSTYLE, ExtendedStyle OR WS_EX_TOOLWINDOW 
        AND NOT WS_EX_APPWINDOW);<br>
        end;</p>
      <p><br>
        end.</p>
      <p><br>
        <font color="#0000FF"><b>使用图片做按扭的控件<font color="#0000FF"><b>=========================================</b> 
        </font></b></font></p>
      <p>{*******************************************************}<br>
        { }<br>
        { ImgButton v2.01 (Freeware) }<br>
        { }<br>
        { Copyright (c) 2002-1 Liren Zhao BeiJing China }<br>
        { }<br>
        { HomePage: Http://Stef.533.net/54 }<br>
        { Http://Aojianjianghu.126.com }<br>
        { }<br>
        { Email:[e-mail] }<br>
        { }<br>
        {*******************************************************}</p>
      <p>unit ImgButton;</p>
      <p>interface</p>
      <p>uses<br>
        Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;</p>
      <p>type<br>
        TImgButton = class(TGraphicControl)<br>
        private<br>
        FGNormal: TBitmap;<br>
        FGMouseDown: TBitMap;<br>
        FGMouseUp: TBitMap;<br>
        FGDisabled: TBitMap;<br>
        tmpBitmap: TBitMap;<br>
        FCaption: String;<br>
        FShowCaption: Boolean;<br>
        FModalResult: TModalResult;<br>
        FFont:TFont;<br>
        procedure SetGNormal(Value: TBitMap);<br>
        procedure SetGMouseDown(Value: TBitMap);<br>
        procedure SetGMouseUp(Value: TBitMap);<br>
        procedure SetGDisabled(Value: TBitMap);<br>
        procedure SetCaption(Value:String);<br>
        procedure Resize(Sender: TObject);<br>
        procedure SetShowCaption(Value:Boolean);<br>
        procedure DrawCaption;<br>
        procedure SetFont(Value:TFont);<br>
        protected<br>
        procedure paint;override;<br>
        procedure MouseEnter(var Msg: TMessage); message CM_MOUSEENTER;<br>
        procedure MouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;<br>
        procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 
        override;<br>
        procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 
        override;<br>
        public<br>
        constructor Create(AOwner: TComponent); override;<br>
        destructor Destroy; override;<br>
        published<br>
        property PictureEnter: TBitMap read FGMouseUp write SetGMouseUp;<br>
        property PictureDown: TBitMap read FGMouseDown write SetGMouseDown;<br>
        property PictureNormal: TBitMap read FGNormal write SetGNormal;<br>
        property PictureDisable: TBitMap read FGDisabled write SetGDisabled;<br>
        property ModalResult: TModalResult read FModalResult write FModalResult 
        default 0;<br>
        property Caption: String read FCaption write SetCaption;<br>
        property ShowCaption:Boolean read FShowCaption write SetShowCaption;<br>
        property Font:TFont read FFont write SetFont;<br>
        property Action;<br>
        property Anchors;<br>
        property Enabled;<br>
        property ParentShowHint;<br>
        property PopupMenu;<br>
        property ShowHint;<br>
        property Visible;<br>
        property OnClick;<br>
        property OnDblClick;<br>
        property OnMouseDown;<br>
        property OnMouseMove;<br>
        property OnMouseUp;<br>
        end;</p>
      <p>procedure Register;</p>
      <p>implementation</p>
      <p>procedure Register;<br>
        begin<br>
        RegisterComponents('Liren.z', [TImgButton]);<br>
        end;</p>
      <p>{ TImgButton }</p>
      <p>constructor TImgButton.Create(AOwner: TComponent);<br>
        begin<br>
        inherited Create(AOwner);<br>
        Width := 100;<br>
        Height := 100;<br>
        FGNormal :=TBitMap.Create;<br>
        FGMouseDown :=TBitMap.Create;<br>
        FGMouseUp :=TBitMap.Create;<br>
        FGDisabled :=TBitMap.Create;<br>
        tmpBitmap :=TBitMap.Create;<br>
        OnResize:=Resize;<br>
        With Canvas.Font do begin<br>
        Charset:=GB2312_CHARSET;<br>
        Color:= clWindowText;<br>
        Height:=-12;<br>
        Name:='宋体';<br>
        Pitch:=fpDefault;<br>
        Size:=9; <br>
        end;<br>
        FFont:=Canvas.Font;<br>
        end;</p>
      <p>destructor TImgButton.Destroy;<br>
        begin<br>
        FGNormal.Free;<br>
        FGMouseDown.Free;<br>
        FGMouseUp.Free;<br>
        FGDisabled.Free;<br>
        tmpBitMap:=nil;<br>
        tmpBitmap.Free;<br>
        inherited Destroy;<br>
        end;</p>
      <p>procedure TImgButton.paint;<br>
        const<br>
        XorColor = $00FFD8CE;<br>
        begin<br>
        with Canvas do begin<br>
        if (csDesigning in ComponentState) then begin<br>
        Pen.Style := psDot;<br>
        Pen.Mode := pmXor;<br>
        Pen.Color := XorColor;<br>
        Brush.Style := bsClear;<br>
        Rectangle(0, 0, ClientWidth, ClientHeight);<br>
        end;</p>
      <p> if not Enabled then<br>
        if not FGDisabled.Empty then<br>
        tmpBitmap:= FGDisabled<br>
        else<br>
        tmpBitMap:=FGNormal<br>
        else<br>
        tmpBitMap:=FGNormal;</p>
      <p> Canvas.StretchDraw(ClientRect, tmpBitmap);<br>
        DrawCaption;<br>
        end;<br>
        end;</p>
      <p>procedure TImgButton.SetGDisabled(Value: TBitMap);<br>
        begin<br>
        FGDisabled.Assign(Value);<br>
        Invalidate;<br>
        end;</p>
      <p>procedure TImgButton.SetGMouseDown(Value: TBitMap);<br>
        begin<br>
        FGMouseDown.Assign(Value);<br>
        Invalidate;<br>
        end;</p>
      <p>procedure TImgButton.SetGNormal(Value: TBitMap);<br>
        begin<br>
        FGNormal.Assign(Value);<br>
        tmpBitmap:= FGNormal;<br>
        Width:=FGNormal.Width;<br>
        Height:=FGNormal.Height;<br>
        Repaint;<br>
        Canvas.StretchDraw(ClientRect, FGNormal);<br>
        Invalidate;<br>
        end;</p>
      <p>procedure TImgButton.SetGMouseUp(Value: TBitMap);<br>
        begin<br>
        FGMouseUp.Assign(Value);<br>
        Invalidate;<br>
        end;</p>
      <p>procedure TImgButton.MouseDown(Button: TMouseButton; Shift: TShiftState; 
        X,Y: Integer);<br>
        begin<br>
        if (x&gt;0) and (x&lt;Width) and (y&gt;0) and (y&lt;Height) then begin<br>
        if button = mbLeft then begin<br>
        Repaint;<br>
        Canvas.StretchDraw(ClientRect, FGMouseDown);<br>
        DrawCaption;<br>
        end;<br>
        end;<br>
        inherited;<br>
        end;</p>
      <p>procedure TImgButton.MouseEnter(var Msg: TMessage);<br>
        begin<br>
        if Enabled then begin<br>
        Repaint;<br>
        Canvas.StretchDraw(ClientRect, FGMouseUp);<br>
        DrawCaption;<br>
        end;<br>
        end;</p>
      <p>procedure TImgButton.MouseLeave(var Msg: TMessage);<br>
        begin<br>
        if Enabled then begin<br>
        Repaint;<br>
        Canvas.StretchDraw(ClientRect, FGNormal);<br>
        DrawCaption;<br>
        end;<br>
        end;</p>
      <p>procedure TImgButton.MouseUp(Button: TMouseButton; Shift: TShiftState; 
        X,<br>
        Y: Integer);<br>
        begin<br>
        if (x&gt;0) and (x&lt;Width) and (y&gt;0) and (y&lt;Height) then begin<br>
        if button = mbLeft then begin<br>
        Repaint;<br>
        Canvas.StretchDraw(ClientRect, FGMouseUp);<br>
        DrawCaption;<br>
        end;<br>
        end;<br>
        inherited;<br>
        end;</p>
      <p><br>
        procedure TImgButton.Resize(Sender: TObject);<br>
        begin<br>
        if not FGNormal.Empty then begin<br>
        Width:=FGNormal.Width;<br>
        Height:=FGNormal.Height;<br>
        DrawCaption;<br>
        end;<br>
        end;</p>
      <p>procedure TImgButton.SetCaption(Value: String);<br>
        begin<br>
        FCaption:=Value;<br>
        DrawCaption;<br>
        Invalidate;<br>
        end;</p>
      <p>procedure TImgButton.DrawCaption;<br>
        var<br>
        x,y:integer;<br>
        begin<br>
        if FShowCaption then begin<br>
        with Canvas do begin<br>
        Brush.Style := bsClear;<br>
        x:=Round((Width-TextWidth(Caption))/2);<br>
        y:=Round((Height-TextHeight(Caption))/2);<br>
        TextOut(x,y,Caption);<br>
        end;<br>
        end;<br>
        end;</p>
      <p>procedure TImgButton.SetShowCaption(Value: Boolean);<br>
        begin<br>
        FShowCaption:=Value;<br>
        Invalidate;<br>
        end;</p>
      <p>procedure TImgButton.SetFont(Value: TFont);<br>
        begin<br>
        FFont:=Value;<br>
        Canvas.Font:=Value;<br>
        Invalidate;<br>
        end;</p>
      <p>end.<br>
      </p>
      <p>&nbsp; </p>
    </td>
  </tr>
</table>
<br>
<div align="center"></div>
<p align="center">资料整理:<a href="http://wlbookwl.myrice.com/" target="_blank">编程先锋 
  http://wlbookwl.myrice.com</a> 站长：小黑侠 </p>
</body>
</html>