rm_dsgctrls.pas

进销存管理 编译环境Delphi7+Win2000 用到的控件 ReportMachine2.6 InfoPower4000Pro_vcl7 RxLib2.7 SkinEngine 3

unit RM_DsgCtrls;

interface

{$I RM.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, Buttons, ComCtrls, Menus, RM_Class;

type

  TFontDevice = (rmfdScreen, rmfdPrinter, rmfdBoth);
  TFontListOption = (rmfoAnsiOnly, rmfoTrueTypeOnly, rmfoFixedPitchOnly,
    rmfoNoOEMFonts, rmfoOEMFontsOnly, rmfoScalableOnly, rmfoNoSymbolFonts);
  TFontListOptions = set of TFontListOption;

{ TRMFontComboBox }
  TRMFontComboBox = class(TComboBox)
  private
  	FFontHeight: Integer;
    FTrueTypeBMP: TBitmap;
    FDeviceBMP: TBitmap;
    FOnChange: TNotifyEvent;
    FDevice: TFontDevice;
    FUpdate: Boolean;
    FOptions: TFontListOptions;
    procedure SetFontName(const NewFontName: TFontName);
    function GetFontName: TFontName;
    function GetTrueTypeOnly: Boolean;
    procedure SetDevice(Value: TFontDevice);
    procedure SetOptions(Value: TFontListOptions);
    procedure SetTrueTypeOnly(Value: Boolean);
    procedure Reset;
    procedure WMFontChange(var Message: TMessage); message WM_FONTCHANGE;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMFontChange(var Message: TMessage); message CM_FONTCHANGE;
  protected
    procedure Init;
    procedure PopulateList; virtual;
    procedure Change; override;
    procedure Click; override;
    procedure DoChange; dynamic;
    procedure CreateWnd; override;
    procedure MeasureItem(Index: Integer; var Height: Integer); override;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Text;
  published
    property Device: TFontDevice read FDevice write SetDevice default rmfdScreen;
    property FontName: TFontName read GetFontName write SetFontName;
    property Options: TFontListOptions read FOptions write SetOptions default [];
    property TrueTypeOnly: Boolean read GetTrueTypeOnly write SetTrueTypeOnly stored False;
    property OnChange;
  end;

  { TRMTrackIcon }
  TRMTrackIcon = class(TGraphicControl)
  private
    TrackBmp: TBitmap;
    FBitmapName: string;
    procedure SetBitmapName(const Value: string);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property BitmapName: string read FBitmapName write SetBitmapName;
  end;

  { TRMRuler }
  TRMRuler = class(TPanel)
  private
    FRichEdit: TCustomRichEdit;
    ScreenPixelsPerInch: integer;
    FDragOfs: Integer;
    FLineDC: HDC;
    FLinePen: HPen;
    FDragging: Boolean;
    FLineVisible: Boolean;
    FLineOfs: Integer;

    FirstInd: TRMTrackIcon;
    LeftInd: TRMTrackIcon;
    RightInd: TRMTrackIcon;
    FOnIndChanged: TNotifyEvent;
    procedure DrawLine;
    procedure CalcLineOffset(Control: TControl);
    function IndentToRuler(Indent: Integer; IsRight: Boolean): Integer;
    function RulerToIndent(RulerPos: Integer; IsRight: Boolean): Integer;
    procedure OnRulerItemMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure OnRulerItemMouseMove(Sender: TObject; Shift: TShiftState;
      X, Y: Integer);
    procedure OnFirstIndMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure OnLeftIndMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure OnRightIndMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure UpdateInd;
    property RichEdit: TCustomRichEdit read FRichEdit write FRichEdit;
    property OnIndChanged: TNotifyEvent read FOnIndChanged write FOnIndChanged;
  end;

  TRMColorType = (rmptFont, rmptLine, rmptFill, rmptHighlight, rmptCustom);

  { TRMColorButton }
  TRMColorButton = class(TSpeedButton)
  protected
    procedure Paint; override;
  public
    property Canvas;
  published
    property Color;
  end;

  { TRMColorPicker }
  TRMColorPicker = class(TCustomPanel)
  private
    FColorDlg: TColorDialog;
    FDDFlat: Boolean;
    FDDAutoColor: TColor;
    FDDIsAuto: Boolean;
    FAutoClicked: Boolean;

    procedure InitButtons;
    procedure OtherBtnClick(Sender: TObject);
    procedure BtnClick(Sender: TObject);
    procedure SetDDAutoColor(Value: TColor);
    procedure SetDDFlat(Value: Boolean);
  public
    AutoBtn: TRMColorButton;
    OtherColBtn: TRMColorButton;
    ColBtns: array[0..39] of TRMColorButton;
    CustColBtns: array[0..15] of TRMColorButton;
    OtherBtn: TSpeedButton;
    DDSelColor: TColor;
    constructor Create(AOwner: TComponent); override;
    property DDAutoColor: TColor read FDDAutoColor write SetDDAutoColor;
    property AutoClicked: Boolean read FAutoClicked default false;
    property DDFlat: Boolean read FDDFlat write SetDDFlat;
  end;

  { TRMColorPickDlg }
  TRMColorPickDlg = class(TForm)
  private
    FColorPick: TRMColorPicker;
    FSendCtrl: TControl;
    FCloseOk: Boolean;
    FOtherOk: Boolean;
    procedure WMKILLFOCUS(var message: TWMKILLFOCUS); message WM_KILLFOCUS;
    procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  public
    SelectedColor: TColor;
    procedure Drop(Sender: TControl);
  end;

  { TRMColorPickerButton }
  TRMColorPickerButton = class(TCustomPanel)
  private
    FDrawButton: TRMColorButton;
    FBtnDropDown: TSpeedButton;
    FFlat: Boolean;
    FDDArrowWidth: byte;
    FCurrentColor: TColor;
    FAutomaticColor: TColor;
    FTargetColor: TColor;
    FColorType: TRMColorType;
    FIsAutomatic: Boolean;
    FOnBtnClick: TNotifyEvent;
    FBeforeDropDown: TNotifyEvent;
    FAutoCaption: string;
    FMoreColorsCaption: string;

    procedure InitButtons;
    procedure Btn1Click(Sender: TObject);
    procedure BtnDropDownClick(Sender: TObject);
    procedure SetCurrentColor(Value: TColor);
    procedure SetColorType(Value: TRMColorType);
    procedure SetFlat(Value: Boolean);
  public
    AutoClicked: Boolean;
    constructor Create(AOwner: TComponent); override;
    procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    procedure InterAdjustSize(var W: Integer; var H: Integer);
//    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure SetControlEnabled;
  published
    property CurrentColor: TColor read FCurrentColor write SetCurrentColor;
    property TargetColor: TColor read FTargetColor write FTargetColor;
    property BeforeDropDown: TNotifyEvent read FBeforeDropDown write FBeforeDropDown;
    property ColorType: TRMColorType read FColorType write SetColorType;
    property Flat: Boolean read FFlat write SetFlat;
    property AutoCaption: string read FAutoCaption write FAutoCaption;
    property MoreColorsCaption: string read FMoreColorsCaption write FMoreColorsCaption;
    property OnColorChange: TNotifyEvent read FOnBtnClick write FOnBtnClick;
    property Hint;
    property Enabled;
  end;

  TRMRulerOrientationType = (roHorizontal, roVertical);

  {@TRMDesignerRuler }
  TRMDesignerRuler = class(TPaintBox)//TGraphicControl)
  private
    FDrawRect: TRect;
    FGuide1X: Integer;
    FGuide1Y: Integer;
    FGuide2X: Integer;
    FGuide2Y: Integer;
    FGuideHeight: Integer;
    FGuideWidth: Integer;
    FHalfTicks: Boolean;
    FMargin: Integer;
    FOrientation: TRMRulerOrientationType;
    FPixelIncrement: Double;
    FScrollOffset: Integer;
    FThickness: Integer;
    FTicksPerUnit: Integer;
    FTickFactor: Single;
    FUnits: TRMSizeUnits;

    procedure DrawGuide(aGuideX, aGuideY: Integer);
    procedure InitGuides;
    procedure PaintRuler;
    procedure SetOrientation(aOrientation: TRMRulerOrientationType);
    procedure SetUnits(aUnit: TRMSizeUnits);
    function UpdateGuidePosition(aNewPosition: Integer; var aGuideX, aGuideY: Integer): Boolean;
    procedure ChangeUnits(aUnit: TRMSizeUnits);
  protected
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure Paint; override;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;

    procedure Scroll(Value: Integer);
    procedure SetGuides(aPosition1, aPosition2: Integer);
    property Orientation: TRMRulerOrientationType read FOrientation write SetOrientation;
    property Units: TRMSizeUnits read FUnits write SetUnits;
  end;

function RMForceDirectories(Dir: string): Boolean;
function RMDirectoryExists(const Name: string): Boolean;
function RMSelectDirectory(const Caption: string; const Root: WideString; var Directory: string): Boolean;

implementation

{$R RM_common.RES}

uses RM_Utils, RM_Const, Printers, Math, ShlObj, ActiveX;

const
  RulerAdj = 4 / 3;

function RMDirectoryExists(const Name: string): Boolean;
var
  Code: Integer;
begin
  Code := GetFileAttributes(PChar(Name));
  Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
end;

{$IFDEF Delphi6}
{$WARN SYMBOL_DEPRECATED OFF}
{$ENDIF}

function RMExcludeTrailingBackslash(const S: string): string;
begin
  Result := S;
  if IsPathDelimiter(Result, Length(Result)) then
    SetLength(Result, Length(Result)-1);
end;

function RMForceDirectories(Dir: string): Boolean;
begin
  Result := True;
  if Length(Dir) = 0 then
  begin
  	Result := False;
    Exit;
  end;
  Dir := RMExcludeTrailingBackslash(Dir);
  if (Length(Dir) < 3) or RMDirectoryExists(Dir)
    or (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem.
  Result := RMForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir);
end;

function RMSelectDirCB(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall;
begin
  if (uMsg = BFFM_INITIALIZED) and (lpData <> 0) then
    SendMessage(Wnd, BFFM_SETSELECTION, Integer(True), lpdata);
  result := 0;
end;

function RMSelectDirectory(const Caption: string; const Root: WideString;
  var Directory: string): Boolean;
var
  WindowList: Pointer;
  BrowseInfo: TBrowseInfo;
  Buffer: PChar;
  OldErrorMode: Cardinal;
  RootItemIDList, ItemIDList: PItemIDList;
  ShellMalloc: IMalloc;
  IDesktopFolder: IShellFolder;
  Eaten, Flags: ULONG {LongWord};
begin
  Result := False;
  if not RMDirectoryExists(Directory) then
    Directory := '';
  FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
  if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
  begin
    Buffer := ShellMalloc.Alloc(MAX_PATH);
    try
      RootItemIDList := nil;
      if Root <> '' then
      begin
        SHGetDesktopFolder(IDesktopFolder);
        IDesktopFolder.ParseDisplayName(Application.Handle, nil,
          POleStr(Root), Eaten, RootItemIDList, Flags);
      end;
      with BrowseInfo do
      begin
        hwndOwner := Application.Handle;
        pidlRoot := RootItemIDList;
        pszDisplayName := Buffer;
        lpszTitle := PChar(Caption);
        ulFlags := BIF_RETURNONLYFSDIRS;
        if Directory <> '' then
        begin
          lpfn := RMSelectDirCB;
          lParam := Integer(PChar(Directory));
        end;
      end;
      WindowList := DisableTaskWindows(0);
      OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
      try
        ItemIDList := ShBrowseForFolder(BrowseInfo);
      finally
        SetErrorMode(OldErrorMode);
        EnableTaskWindows(WindowList);
      end;
      Result := ItemIDList <> nil;
      if Result then
      begin
        ShGetPathFromIDList(ItemIDList, Buffer);
        ShellMalloc.Free(ItemIDList);
        Directory := Buffer;
      end;
    finally
      ShellMalloc.Free(Buffer);
    end;
  end;
end;

{$IFNDEF Delphi4}

function Max(Value1, Value2: Integer): Integer;
begin
  if Value1 > Value2 then
    Result := Value1
  else
    Result := Value2;
end;

function Min(Value1, Value2: Integer): Integer;
begin
  if Value1 > Value2 then
    Result := Value2
  else
    Result := Value1;
end;
{$ENDIF}

function GetFontMetrics(Font: TFont): TTextMetric;
var
  DC: HDC;
  SaveFont: HFont;
begin
  DC := GetDC(0);
  SaveFont := SelectObject(DC, Font.Handle);
  GetTextMetrics(DC, Result);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);
end;

function GetFontHeight(Font: TFont): Integer;
begin
  Result := GetFontMetrics(Font).tmHeight;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMFontComboBox}

{function GetItemHeight(Font: TFont): Integer;
var
  DC: HDC;
  SaveFont: HFont;
  Metrics: TTextMetric;
begin
  DC := GetDC(0);
  try
    SaveFont := SelectObject(DC, Font.Handle);
    GetTextMetrics(DC, Metrics);
    SelectObject(DC, SaveFont);
  finally
    ReleaseDC(0, DC);
  end;
  Result := Metrics.tmHeight + 2;
end;
}
const
  WRITABLE_FONTTYPE = 256;

function IsValidFont(Box: TRMFontComboBox; LogFont: TLogFont; FontType: Integer): Boolean;
begin
  Result := True;
  if (rmfoAnsiOnly in Box.Options) then
    Result := Result and (LogFont.lfCharSet = ANSI_CHARSET);
  if (rmfoTrueTypeOnly in Box.Options) then
    Result := Result and (FontType and TRUETYPE_FONTTYPE = TRUETYPE_FONTTYPE);
  if (rmfoFixedPitchOnly in Box.Options) then
    Result := Result and (LogFont.lfPitchAndFamily and FIXED_PITCH = FIXED_PITCH);
  if (rmfoOEMFontsOnly in Box.Options) then
    Result := Result and (LogFont.lfCharSet = OEM_CHARSET);
  if (rmfoNoOEMFonts in Box.Options) then
    Result := Result and (LogFont.lfCharSet <> OEM_CHARSET);
  if (rmfoNoSymbolFonts in Box.Options) then
    Result := Result and (LogFont.lfCharSet <> SYMBOL_CHARSET);
  if (rmfoScalableOnly in Box.Options) then
    Result := Result and (FontType and RASTER_FONTTYPE = 0);
end;

function EnumFontsProc(var EnumLogFont: TEnumLogFont; var TextMetric: TNewTextMetric;
	FontType: Integer; Data: LPARAM): Integer; export; stdcall;
var
  FaceName: string;
begin
  FaceName := StrPas(EnumLogFont.elfLogFont.lfFaceName);
  with TRMFontComboBox(Data) do
  begin
    if (Items.IndexOf(FaceName) < 0) and
      IsValidFont(TRMFontComboBox(Data), EnumLogFont.elfLogFont, FontType) then
    begin
      if EnumLogFont.elfLogFont.lfCharSet <> SYMBOL_CHARSET then
        FontType := FontType or WRITABLE_FONTTYPE;
      Items.AddObject(FaceName, TObject(FontType));
    end;
  end;
  Result := 1;
end;

constructor TRMFontComboBox.Create(AOwner: TComponent);
var
	liFont: TFont;