rm_common.pas

进销存·完整的·有数据库的·非常完整·只得参考

{$ENDIF}
    lWidth := f.Width;
    lHeight := f.Height;
  end;
  Ini.WriteInteger(Name, rsX, X);
  Ini.WriteInteger(Name, rsY, Y);
  Ini.WriteInteger(Name, rsWidth, lWidth);
  Ini.WriteInteger(Name, rsHeight, lHeight);
{$IFDEF USE_TB2K}
  if f.CurrentDock <> nil then
  begin
    Ini.WriteString(Name, rsDockName, f.CurrentDock.Name);
    Ini.WriteBool(Name, rsDocked, TRUE);
  end
{$ELSE}
  if f.DockedTo <> nil then
  begin
    Ini.WriteString(Name, rsDockName, f.DockedTo.Name);
    Ini.WriteBool(Name, rsDocked, TRUE);
  end
{$ENDIF}
  else
  begin
    Ini.WriteString(Name, rsDockName, '');
    Ini.WriteBool(Name, rsDocked, FALSE);
  end;
  Ini.Free;
end;

procedure RMRestoreToolWinPosition(f: TRMToolWin);
var
  Ini: TRegIniFile;
  Name: string;
  X, Y: integer;
  DN: string;
  NewDock: TRMDock;
  DNDocked: Boolean;
begin
  Ini := TRegIniFile.Create(RegRootKey);
  Name := rsForm + f.ClassName;

  f.Visible := False;
  X := Ini.ReadInteger(Name, rsX, f.Left);
  Y := Ini.ReadInteger(Name, rsY, f.Top);
  f.Width := Ini.ReadInteger(Name, rsWidth, f.Width);
  if f.Width < 40 then f.Width := 40;
  f.Height := Ini.ReadInteger(Name, rsHeight, f.Height);
  if f.Height < 40 then f.Height := 40;

  DNDocked := Ini.ReadBool(Name, rsDocked, TRUE);
  if DNDocked then
  begin
    DN := Ini.ReadString(Name, rsDockName, '');
    if f.Owner <> nil then
    begin
      NewDock := (f.Owner).FindComponent(DN) as TRMDock;
      if NewDock <> nil then
      begin
{$IFDEF USE_TB2K}
        f.CurrentDock := NewDock;
{$ELSE}
        f.DockedTo := NewDock;
{$ENDIF}
        f.DockPos := X;
        f.DockRow := Y;
      end;
    end;
  end
  else
  begin
{$IFDEF USE_TB2K}
    f.CurrentDock := nil;
{$ELSE}
    f.DockedTo := nil;
{$ENDIF}
{$IFDEF USE_TB2K}
    f.FloatingPosition := Point(X, Y);
    f.Floating := True;
    f.MoveOnScreen(True);
{$ELSE}
    f.Left := X;
    f.Top := Y;
{$ENDIF}
  end;
  f.Visible := Ini.ReadBool(Name, rsVisible, True);

  Ini.Free;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMToolbarButton}

{$IFDEF USE_TB2k}

function TRMToolbarButton.GetDown: Boolean;
begin
  Result := Checked;
end;

procedure TRMToolbarButton.SetDown(Value: Boolean);
begin
  Checked := Value;
end;

function TRMToolbarButton.GetAllowAllUp: Boolean;
begin
  Result := AutoCheck;
end;

procedure TRMToolbarButton.SetAllowAllUp(Value: Boolean);
begin
  AutoCheck := Value;
end;
{$ENDIF}

{ TRMSpinButton }

constructor TRMSpinButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FUpBitmap := TBitmap.Create;
  FDownBitmap := TBitmap.Create;
  FUpBitmap.Handle := LoadBitmap(HInstance, sSpinUpBtn);
  FDownBitmap.Handle := LoadBitmap(HInstance, sSpinDownBtn);
  FUpBitmap.OnChange := GlyphChanged;
  FDownBitmap.OnChange := GlyphChanged;
  Height := 20;
  Width := 20;
  FTopDownBtn := TBitmap.Create;
  FBottomDownBtn := TBitmap.Create;
  FNotDownBtn := TBitmap.Create;
  DrawAllBitmap;
  FLastDown := rmsbNotDown;
end;

destructor TRMSpinButton.Destroy;
begin
  FTopDownBtn.Free;
  FBottomDownBtn.Free;
  FNotDownBtn.Free;
  FUpBitmap.Free;
  FDownBitmap.Free;
  FRepeatTimer.Free;
  inherited Destroy;
end;

procedure TRMSpinButton.GlyphChanged(Sender: TObject);
begin
  FInvalidate := True;
  Invalidate;
end;

procedure TRMSpinButton.SetDown(Value: TRMSpinButtonState);
var
  OldState: TRMSpinButtonState;
begin
  OldState := FDown;
  FDown := Value;
  if OldState <> FDown then
    Repaint;
end;

procedure TRMSpinButton.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = FFocusControl) then
    FFocusControl := nil;
end;

procedure TRMSpinButton.Paint;
begin
  if not Enabled and not (csDesigning in ComponentState) then
    FDragging := False;
  if (FNotDownBtn.Height <> Height) or (FNotDownBtn.Width <> Width) or FInvalidate then
    DrawAllBitmap;
  FInvalidate := False;
  with Canvas do
    case FDown of
      rmsbNotDown: Draw(0, 0, FNotDownBtn);
      rmsbTopDown: Draw(0, 0, FTopDownBtn);
      rmsbBottomDown: Draw(0, 0, FBottomDownBtn);
    end;
end;

procedure TRMSpinButton.DrawAllBitmap;
begin
  DrawBitmap(FTopDownBtn, rmsbTopDown);
  DrawBitmap(FBottomDownBtn, rmsbBottomDown);
  DrawBitmap(FNotDownBtn, rmsbNotDown);
end;

procedure TRMSpinButton.DrawBitmap(ABitmap: TBitmap; ADownState: TRMSpinButtonState);
var
  R, RSrc: TRect;
  dRect: Integer;
begin
  ABitmap.Height := Height;
  ABitmap.Width := Width;
  with ABitmap.Canvas do
  begin
    R := Bounds(0, 0, Width, Height);
    Pen.Width := 1;
    Brush.Color := clBtnFace;
    Brush.Style := bsSolid;
    FillRect(R);
    { buttons frame }
    Pen.Color := clWindowFrame;
    Rectangle(0, 0, Width, Height);
    MoveTo(-1, Height);
    LineTo(Width, -1);
    { top button }
    if ADownState = rmsbTopDown then
      Pen.Color := clBtnShadow
    else
      Pen.Color := clBtnHighlight;
    MoveTo(1, Height - 4);
    LineTo(1, 1);
    LineTo(Width - 3, 1);
    if ADownState = rmsbTopDown then
      Pen.Color := clBtnHighlight
    else
      Pen.Color := clBtnShadow;
    if ADownState <> rmsbTopDown then
    begin
      MoveTo(1, Height - 3);
      LineTo(Width - 2, 0);
    end;
    { bottom button }
    if ADownState = rmsbBottomDown then
      Pen.Color := clBtnHighlight
    else
      Pen.Color := clBtnShadow;
    MoveTo(2, Height - 2);
    LineTo(Width - 2, Height - 2);
    LineTo(Width - 2, 1);
    if ADownState = rmsbBottomDown then
      Pen.Color := clBtnShadow
    else
      Pen.Color := clBtnHighlight;
    MoveTo(2, Height - 2);
    LineTo(Width - 1, 1);
    { top glyph }
    dRect := 1;
    if ADownState = rmsbTopDown then
      Inc(dRect);
    R := Bounds(Round((Width / 4) - (FUpBitmap.Width / 2)) + dRect,
      Round((Height / 4) - (FUpBitmap.Height / 2)) + dRect, FUpBitmap.Width,
      FUpBitmap.Height);
    RSrc := Bounds(0, 0, FUpBitmap.Width, FUpBitmap.Height);
    BrushCopy(R, FUpBitmap, RSrc, FUpBitmap.TransparentColor);
    { bottom glyph }
    R := Bounds(Round((3 * Width / 4) - (FDownBitmap.Width / 2)) - 1,
      Round((3 * Height / 4) - (FDownBitmap.Height / 2)) - 1,
      FDownBitmap.Width, FDownBitmap.Height);
    RSrc := Bounds(0, 0, FDownBitmap.Width, FDownBitmap.Height);
    BrushCopy(R, FDownBitmap, RSrc, FDownBitmap.TransparentColor);
    if ADownState = rmsbBottomDown then
    begin
      Pen.Color := clBtnShadow;
      MoveTo(3, Height - 2);
      LineTo(Width - 1, 2);
    end;
  end;
end;

procedure TRMSpinButton.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  FInvalidate := True;
  Invalidate;
end;

procedure TRMSpinButton.TopClick;
begin
  if Assigned(FOnTopClick) then
  begin
    FOnTopClick(Self);
    if not (csLButtonDown in ControlState) then
      FDown := rmsbNotDown;
  end;
end;

procedure TRMSpinButton.BottomClick;
begin
  if Assigned(FOnBottomClick) then
  begin
    FOnBottomClick(Self);
    if not (csLButtonDown in ControlState) then
      FDown := rmsbNotDown;
  end;
end;

procedure TRMSpinButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseDown(Button, Shift, X, Y);
  if (Button = mbLeft) and Enabled then
  begin
    if (FFocusControl <> nil) and FFocusControl.TabStop and
      FFocusControl.CanFocus and (GetFocus <> FFocusControl.Handle) then
      FFocusControl.SetFocus;
    if FDown = rmsbNotDown then
    begin
      FLastDown := FDown;
      if Y > (-(Height / Width) * X + Height) then
      begin
        FDown := rmsbBottomDown;
        BottomClick;
      end
      else
      begin
        FDown := rmsbTopDown;
        TopClick;
      end;
      if FLastDown <> FDown then
      begin
        FLastDown := FDown;
        Repaint;
      end;
      if FRepeatTimer = nil then
        FRepeatTimer := TTimer.Create(Self);
      FRepeatTimer.OnTimer := TimerExpired;
      FRepeatTimer.Interval := InitRepeatPause;
      FRepeatTimer.Enabled := True;
    end;
    FDragging := True;
  end;
end;

procedure TRMSpinButton.MouseMove(Shift: TShiftState; X, Y: Integer);
var
  NewState: TRMSpinButtonState;
begin
  inherited MouseMove(Shift, X, Y);
  if FDragging then
  begin
    if (X >= 0) and (X <= Width) and (Y >= 0) and (Y <= Height) then
    begin
      NewState := FDown;
      if Y > (-(Width / Height) * X + Height) then
      begin
        if (FDown <> rmsbBottomDown) then
        begin
          if FLastDown = rmsbBottomDown then
            FDown := rmsbBottomDown
          else
            FDown := rmsbNotDown;
          if NewState <> FDown then
            Repaint;
        end;
      end
      else
      begin
        if (FDown <> rmsbTopDown) then
        begin
          if (FLastDown = rmsbTopDown) then
            FDown := rmsbTopDown
          else
            FDown := rmsbNotDown;
          if NewState <> FDown then
            Repaint;
        end;
      end;
    end
    else if FDown <> rmsbNotDown then
    begin
      FDown := rmsbNotDown;
      Repaint;
    end;
  end;
end;

procedure TRMSpinButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);
  if FDragging then
  begin
    FDragging := False;
    if (X >= 0) and (X <= Width) and (Y >= 0) and (Y <= Height) then
    begin
      FDown := rmsbNotDown;
      FLastDown := rmsbNotDown;
      Repaint;
    end;
  end;
end;

procedure TRMSpinButton.TimerExpired(Sender: TObject);
begin
  FRepeatTimer.Interval := RepeatPause;
  if (FDown <> rmsbNotDown) and MouseCapture then
  begin
    try
      if FDown = rmsbBottomDown then
        BottomClick
      else
        TopClick;
    except
      FRepeatTimer.Enabled := False;
      raise;
    end;
  end;
end;

function DefBtnWidth: Integer;
begin
  Result := GetSystemMetrics(SM_CXVSCROLL);
  if Result > 15 then
    Result := 15;
end;

type
  TRxUpDown = class(TCustomUpDown)
  private
    FChanging: Boolean;
    procedure ScrollMessage(var Message: TWMVScroll);
    procedure WMHScroll(var Message: TWMHScroll); message CN_HSCROLL;
    procedure WMVScroll(var Message: TWMVScroll); message CN_VSCROLL;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property OnClick;
  end;

constructor TRxUpDown.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Orientation := udVertical;
  Min := -1;
  Max := 1;
  Position := 0;
end;

destructor TRxUpDown.Destroy;
begin
  OnClick := nil;
  inherited Destroy;
end;

procedure TRxUpDown.ScrollMessage(var Message: TWMVScroll);
begin
  if Message.ScrollCode = SB_THUMBPOSITION then
  begin
    if not FChanging then
    begin
      FChanging := True;
      try
        if Message.Pos > 0 then
          Click(btNext)
        else if Message.Pos < 0 then
          Click(btPrev);
        if HandleAllocated then
          SendMessage(Handle, UDM_SETPOS, 0, 0);
      finally
        FChanging := False;
      end;
    end;
  end;
end;

procedure TRxUpDown.WMHScroll(var Message: TWMHScroll);
begin
  ScrollMessage(TWMVScroll(Message));
end;

procedure TRxUpDown.WMVScroll(var Message: TWMVScroll);
begin
  ScrollMessage(Message);
end;

procedure TRxUpDown.WMSize(var Message: TWMSize);
begin
  inherited;
  if Width <> DefBtnWidth then