lbmorphvclbase.pas

天涯進銷存系統

begin
  if FGlyph.Empty then Exit;
  if FMouseIn and FDown and (FNumGlyphs > 3)
  then
    PaintGlyph(DG.Canvas, gx, gy, FGlyph, 3, FNumGlyphs)
  else
    if FMouseIn and (FNumGlyphs > 2)
    then
      PaintGlyph(DG.Canvas, gx, gy, FGlyph, 2, FNumGlyphs)
    else
      if Enabled
      then
        PaintGlyph(DG.Canvas, gx, gy, FGlyph, 1, FNumGlyphs)
      else
        PaintGlyph(DG.Canvas, gx, gy, FGlyph, FNumGlyphs, FNumGlyphs);
end;


procedure TButtonGControl.SetLayout(Value: TLayout);
begin
  FLayout := Value;
  XPaint;
end;

procedure TButtonGControl.SetMargin(Value: Integer);
begin
  if (Value <> FMargin) and (Value >= -1) then
  begin
    FMargin := Value;
    XPaint;
  end;
end;

procedure TButtonGControl.SetSpacing(Value: Integer);
begin
  if Value <> FSpacing then
  begin
    FSpacing := Value;
    XPaint;
  end;
end;

function TButtonGControl.IsMouseIn(X,Y: Integer): boolean;
begin
  if (X > 0) and (Y > 0) and (X < Width) and (Y < Height)
  then
    Result := True
  else
    Result := False;
end;

procedure TButtonGControl.Notification(AComponent: TComponent;
      Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
end;

procedure TButtonGControl.MouseDown;
begin
  if (Button = mbLeft) and IsMouseIn(X, Y)
  then
    begin
      FDown := True;
      FMouseIn := True;
      XPaint;
    end;
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TButtonGControl.MouseUp;
begin
  if Button = mbLeft then
  begin
    FDown := False;
    if FMouseIn then
    begin
      XPaint;
      inherited MouseUp(Button, Shift, X, Y);
      if Assigned(FOnClick) then FOnClick(Self);
    end;
  end;
end;


procedure TButtonGControl.CMMouseEnter(var Message: TMessage);
begin
  inherited;
  if not FMouseIn and Enabled
  then
    begin
      FMouseIn := True;
      XPaint;
    end;
end;

procedure TButtonGControl.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  if FMouseIn and Enabled
  then
    begin
      FMouseIn := False;
      XPaint;
    end;
end;

procedure TButtonGControl.CMTextChanged(var Message: TMessage);
begin
  XPaint;
end;

constructor TButtonCControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FGlyph := TBitMap.Create;
  FNumGlyphs := 1;
  FSpacing := 0;
  FMargin := -1;
end;

destructor TButtonCControl.Destroy;
begin
  FGlyph.Free;
  inherited Destroy;
end;

{$IFDEF EPD4  OR CBUILDER4}
procedure TButtonCControl.ActionChange(Sender: TObject; CheckDefaults: Boolean);
  procedure CopyImage(ImageList: TCustomImageList; Index: Integer);
  begin
    with FGlyph do
    begin
      Width := ImageList.Width;
      Height := ImageList.Height;
      Canvas.Brush.Color := clFuchsia;
      Canvas.FillRect(Rect(0,0, Width, Height));
      ImageList.Draw(Canvas, 0, 0, Index);
    end;
  end;

begin
  inherited ActionChange(Sender, CheckDefaults);
  if Sender is TCustomAction then
    with TCustomAction(Sender) do
    begin
      if (FGlyph.Empty) and (ActionList <> nil) and (ActionList.Images <> nil) and
        (ImageIndex >= 0) and (ImageIndex < ActionList.Images.Count) then
      begin
        CopyImage(ActionList.Images, ImageIndex);
        RePaint;
      end;
    end;
end;
{$ENDIF}

procedure TButtonCControl.SetGlyph(Value: TBitmap);
begin
  FGlyph.Assign(Value);
  RePaint;
end;

procedure TButtonCControl.SetNumGlyphs(Value: TNumGlyphs);
begin
  FNumGlyphs := Value;
  RePaint;
end;

procedure TButtonCControl.SetLayout(Value: TLayout);
begin
  FLayout := Value;
  RePaint;
end;

procedure TButtonCControl.DrawButtonGlyph;
begin
  if FGlyph.Empty then Exit;
  if FMouseIn and FDown and (FNumGlyphs > 3)
  then
    PaintGlyph(DG.Canvas, gx, gy, FGlyph, 3, FNumGlyphs)
  else
    if FMouseIn and (FNumGlyphs > 2)
    then
      PaintGlyph(DG.Canvas, gx, gy, FGlyph, 2, FNumGlyphs)
    else
      if Enabled
      then
        PaintGlyph(DG.Canvas, gx, gy, FGlyph, 1, FNumGlyphs)
      else
        PaintGlyph(DG.Canvas, gx, gy, FGlyph, FNumGlyphs, FNumGlyphs);
end;




procedure TButtonCControl.SetMargin(Value: Integer);
begin
  if (Value <> FMargin) and (Value >= -1) then
  begin
    FMargin := Value;
    RePaint;
  end;
end;

procedure TButtonCControl.SetSpacing(Value: Integer);
begin
  if Value <> FSpacing then
  begin
    FSpacing := Value;
    RePaint;
  end;
end;

function TButtonCControl.IsMouseIn(X,Y: Integer): boolean;
begin
  if (X > 0) and (Y > 0) and (X < Width) and (Y < Height)
  then
    Result := True
  else
    Result := False;
end;

procedure TButtonCControl.MouseDown;
begin
  if (Button = mbLeft) and IsMouseIn(X, Y)
  then
    begin
      FDown := True;
      FMouseIn := True;
      RePaint;
    end;
  inherited MouseDown(Button, Shift, X, Y);
end;

procedure TButtonCControl.WMEraseBkGnd(var Msg: TWMEraseBkgnd);
begin
end;

procedure TButtonCControl.Notification(AComponent: TComponent;
      Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
end;

procedure TButtonCControl.MouseUp;
begin
  if Button = mbLeft then
  begin
    FDown := False;
    if FMouseIn then
    begin
      RePaint;
      inherited MouseUp(Button, Shift, X, Y);
      if Assigned(FOnClick) then FOnClick(Self);
    end;
  end;
end;


procedure TButtonCControl.CMMouseEnter(var Message: TMessage);
begin
  inherited;
  if not FMouseIn and Enabled
  then
    begin
      FMouseIn := True;
      RePaint;
    end;
end;

procedure TButtonCControl.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  if FMouseIn and Enabled
  then
    begin
      FMouseIn := False;
      RePaint;
    end;
end;

procedure TButtonCControl.CMTextChanged(var Message: TMessage);
begin
  RePaint;
end;

procedure TButtonCControl.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  RePaint;
end;

constructor TEffectGControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
end;

constructor TEffectCControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
end;


procedure TEffectCControl.PaintTransparent;
begin
  DG.Canvas.Brush.Color := TParentControl(Self.Parent).Color;
  DG.Canvas.FillRect(Bounds(0, 0, Width, Height));
  CopyParentImage(Self,DG.Canvas);
end;

procedure TEffectCControl.WMEraseBkGnd(var Msg: TWMEraseBkgnd);
begin
end;

procedure TEffectGControl.PaintTransparent;
begin
  DG.Canvas.Brush.Color := TParentControl(Self.Parent).Color;
  DG.Canvas.FillRect(Bounds(0, 0, Width, Height));
  CopyParentImage(Self,DG.Canvas);
end;

procedure TEffectCControl.SetTransparent;
begin
  FTransparent := Value;
  RePaint;
end;

procedure TEffectGControl.SetTransparent;
begin
  FTransparent := Value;
  if FTransparent
  then
    ControlStyle := ControlStyle - [csOpaque]
  else
    ControlStyle := ControlStyle + [csOpaque];
  RePaint;
end;


procedure TEffectCControl.PaintFace;
begin
end;

procedure TEffectGControl.PaintFace;
begin
end;

procedure TEffectCControl.PaintEffects;
begin
end;

procedure TEffectGControl.PaintEffects;
begin
end;


procedure TEffectCControl.PaintEf;
begin
  FB := TEffectBmp.CreateFromhWnd(DG.Handle);
  PaintEffects;
  FB.Draw(DG.Canvas.Handle, 0, 0);
  FB.Free;
end;

procedure TEffectGControl.PaintEf;
begin
  FB := TEffectBmp.CreateFromhWnd(DG.Handle);
  PaintEffects;
  FB.Draw(DG.Canvas.Handle, 0, 0);
  FB.Free;
end;


procedure TEffectGControl.XPaint;
begin
  if csOpaque in ControlStyle
  then
    RePaint
  else
   begin
     ControlStyle := ControlStyle + [csOpaque];
     RePaint;
     ControlStyle := ControlStyle - [csOpaque];
   end;
end;

procedure TEffectCControl.Paint;
begin
  DG := TBitMap.Create;
  DG.Width := Width + 1;
  DG.Height := Height + 1;
  DG.Canvas.Font := Self.Font;
  if FTransparent
   then
     PaintTransparent
   else
     with DG.Canvas do
     begin
       Brush.Style := bsSolid;
       Brush.Color := Self.Color;
       FillRect(Rect(0,0,DG.Width,DG.Height));
     end;
  PaintFace;
  Canvas.Draw(0,0,DG);
  DG.Free;
end;

procedure TEffectGControl.Paint;
begin
  DG := TBitMap.Create;
  DG.Width := Width + 1;
  DG.Height := Height + 1;
  DG.Canvas.Font := Self.Font;
  if FTransparent
   then
     PaintTransparent
   else
     with DG.Canvas do
     begin
       Brush.Style := bsSolid;
       Brush.Color := Self.Color;
       FillRect(Rect(0,0,DG.Width,DG.Height));
     end;
  PaintFace;
  Canvas.Draw(0,0,DG);
  DG.Free;
end;

procedure TEffectCControl.WMMove;
begin
  if FTransparent then RePaint;
end;

procedure TEffectGControl.WMMove;
begin
  if FTransparent then RePaint;
end;

procedure CalcLCoord;
var
  H, W, H1, W1: Integer;
begin
 H := R.Top + (R.Bottom - R.Top) div 2;
 W := R.Left + (R.Right - R.Left) div 2;
 if margin = -1
 then
   begin
     W1 := (tw + gw + spacing) div 2;
     H1 := (th + gh + spacing) div 2;
     case Layout of
       blGlyphRight:
         begin
           tx := W - W1;
           ty := H - th div 2;
           gx := W + W1 - gw;
           gy := H - gh div 2;
         end;
      blGlyphLeft:
         begin
           gx := W - W1;
           gy := H - gh div 2;
           tx := W + W1 - tw;
           ty := H - th div 2;
         end;
      blGlyphTop:
         begin
           tx := W - tw div 2;
           ty := H + H1 - th;
           gx := W - gw div 2;
           gy := H - H1;
        end;
     blGlyphBottom:
        begin
          gx := W - gw div 2;
          gy := H + H1 - gh;
          tx := W - tw div 2;
          ty := H - H1;
       end;
     end;
   end
 else
   begin
     case Layout of
       blGlyphRight:
         begin
           gy := H - gh div 2;
           gx := R.Right - gw - margin;
           tx := gx - spacing - tw;
           ty := H - th div 2;
         end;
       blGlyphLeft:
         begin
           gy := H - gh div 2;
           gx := R.Left + margin;
           tx := gx + gw + spacing;
           ty := H - th div 2;
         end;
       blGlyphTop:
          begin
            gy := R.Top +  margin;
            gx := W - gw div 2;
            ty := gy + gh + spacing;
            tx := W - tw div 2;
          end;
      blGlyphBottom:
          begin
            gy := R.Bottom - gh - margin;
            gx := W - gw div 2;
            ty := gy - spacing - th;
            tx := W - tw div 2;
         end;
       end;
    end;
end;

end.