请大家帮帮我呀,我找了一个控件怎么编译通不过呀,他会报错(DesignEditors中的IsProxyClass),不胜感激!(100分)

P

pmis

Unregistered / Unconfirmed
GUEST, unregistred user!
unit MsgDlg;

interface

uses
SysUtils, Windows, Graphics, Forms, Dialogs, ExtCtrls, Controls, StdCtrls,
Buttons, DesignIntf, Classes, Gauges,DesignEditors;

const
_VERSION = '1.3';

type
TfmMsgEditor = class(TForm)
Msg: TMemo;
Panel1: TPanel;
btnOK: TButton;
btnCancel: TButton;
procedure FormKeyPress(Sender: TObject; var Key: Char);
private
end;

TMessageDlg = class;

TMessageForm = class(TForm)
private
procedure HelpButtonClick(Sender: TObject);
procedure ButtonClick(Sender: TObject);
public
CheckBox: TCheckBox;
Gauge: TGauge;
Modeless: Boolean;
MsgDlg: TMessageDlg;
MainMsg: TLabel;
constructor CreateNew(AOwner: TComponent); reintroduce;
destructor Destroy; override;
end;

TTimeOutResult = (trNone,trOk,trCancel,trAbort,trRetry,trIgnore,trYes,trNo,trAll,trNoToAll,trYesToAll);

TMessageDlg = class(TComponent)
private
Seconds,FTimeOut: Byte;
FMsg: String;
FDlgType: TMsgDlgType;
FButtons: TMsgDlgButtons;
FCheckBox: Boolean;
FIniSection: String;
FIniItem: String;
FIniFile: String;
FTimeOutResult: TTimeOutResult;
FCheckBoxCaption: String;
FCustomCaption: String;
FCustomIcon: TIcon;
FHelpContext: Longint;
FHelpFile: String;
FUseRegistry: Boolean;
FTimer: TTimer;
Checked: Boolean;
FGaugeShowText: Boolean;
FGaugeBackColor: TColor;
FGaugeForeColor: TColor;
FModeless: Boolean;
FGaugeMaxValue: Integer;
FColor: TColor;
FFont: TFont;
FButtonFont: TFont;
FVersion: String;
FAllowBlankINI: Boolean;
TimerLabel: TLabel;
FShowCountDown: Boolean;
procedure SetCustomIcon(const Value: TIcon);
procedure SetCheckBoxCaption(const Value: String);
procedure TimerEvent(Sender: TObject);
procedure SetIniItem(const Value: String);
function CreateMessageDialog: TMessageForm;
procedure CheckCheckBox(AResult: Integer);
procedure SetModeless(const Value: Boolean);
procedure SetCheckBox(const Value: Boolean);
procedure SetButtons(const Value: TMsgDlgButtons);
procedure SetFont(const Value: TFont);
procedure SetButtonFont(const Value: TFont);
procedure SetMsg(const Value: String);
procedure SetVersion(const Value: String);
procedure SetTimeOutResult(const Value: TTimeOutResult);
procedure ValidateTimeOutResult;
public
DlgForm: TMessageForm;
function Execute: Integer; overload;
function Execute(AMsg: String; ADlgType: TMsgDlgType; AButtons: TMsgDlgButtons; AHelpContext: Longint): Integer; overload;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure IncGauge; overload;
procedure IncGauge(Value: Integer); overload;
procedure Close;
procedure Hide;
procedure Show;
published
property AllowBlankINI: Boolean read FAllowBlankINI write FAllowBlankINI;
property CustomCaption: String read FCustomCaption write FCustomCaption;
property TimeOut: Byte read FTimeOut write FTimeOut;
property Msg: String read FMsg write SetMsg;
property DlgType: TMsgDlgType read FDlgType write FDlgType;
property Buttons: TMsgDlgButtons read FButtons write SetButtons default [mbOk];
property CheckBox: Boolean read FCheckBox write SetCheckBox;
property Color: TColor read FColor write FColor default clWindow;
property ButtonFont: TFont read FButtonFont write SetButtonFont;
property Font: TFont read FFont write SetFont;
property IniFile: String read FIniFile write FIniFile;
property IniSection: String read FIniSection write FIniSection;
property IniItem: String read FIniItem write SetIniItem;
property UseRegistry: Boolean read FUseRegistry write FUseRegistry;
property TimeOutResult: TTimeOutResult read FTimeOutResult write SetTimeOutResult default trCancel;
property CheckBoxCaption: String read FCheckBoxCaption write SetCheckBoxCaption;
property CustomIcon: TIcon read FCustomIcon write SetCustomIcon;
property HelpFile: String read FHelpFile write FHelpFile;
property HelpContext: Longint read FHelpContext write FHelpContext;
property GaugeMaxValue: Integer read FGaugeMaxValue write FGaugeMaxValue;
property GaugeForeColor: TColor read FGaugeForeColor write FGaugeForeColor default clBlue;
property GaugeBackColor: TColor read FGaugeBackColor write FGaugeBackColor default clWindow;
property GaugeShowText: Boolean read FGaugeShowText write FGaugeShowText default True;
property Modeless: Boolean read FModeless write SetModeless;
property ShowCountdown: Boolean read FShowCountDown write FShowCountDown;
property Version: String read FVersion write SetVersion;
end;

TMsgProperty = class(TStringProperty)
public
procedure Edit; override;
function GetAttributes: TPropertyAttributes; override;
function GetEditLimit: Integer; override;
end;

procedure Register;

implementation

uses
TypInfo, Registry, IniFiles, Math, Consts;

{$R *.DFM}

var
Captions: array[TMsgDlgType] of String = ('Warning','Error','Information','Confirm','');
IconIDs: array[TMsgDlgType] of PChar = (IDI_EXCLAMATION,IDI_HAND,IDI_ASTERISK,IDI_QUESTION,nil);
ButtonNames: array[TMsgDlgBtn] of string = ('Yes','No','OK','Cancel','Abort','Retry','Ignore','All','NoToAll','YesToAll','Help');
ButtonCaptions: array[TMsgDlgBtn] of String = ('&Yes','&No','OK','Cancel','&Abort','&Retry','&Ignore','&All','N&o to All','Yes to &All','Help');
ButtonWidths : array[TMsgDlgBtn] of integer; // initialized to zero
ModalResults: array[TMsgDlgBtn] of Integer = (mrYes,mrNo,mrOk,mrCancel,mrAbort,mrRetry,mrIgnore,mrAll,mrNoToAll,mrYesToAll,0);

{ TMessageForm }

constructor TMessageForm.CreateNew(AOwner: TComponent);
var
NonClientMetrics: TNonClientMetrics;

begin
inherited CreateNew(AOwner);

NonClientMetrics.cbSize := SizeOf(NonClientMetrics);

if SystemParametersInfo(SPI_GETNONCLIENTMETRICS,0,@NonClientMetrics,0) then
Font.Handle := CreateFontIndirect(NonClientMetrics.lfMessageFont);
end;

destructor TMessageForm.Destroy;
begin
inherited;
end;

procedure TMessageForm.HelpButtonClick(Sender: TObject);
begin
Application.HelpContext(HelpContext);
end;

procedure TMessageForm.ButtonClick(Sender: TObject);
begin
if Modeless then begin
Close;
MsgDlg.CheckCheckBox(ModalResult);
end;
end;

{ TMessageForm }

function GetAveCharSize(Canvas: TCanvas): TPoint;
var
I: Integer;
Buffer: array[0..51] of Char;
begin
for I := 0 to 25 do
Buffer := Chr(I + Ord('A'));

for I := 0 to 25 do
Buffer[I + 26] := Chr(I + Ord('a'));

GetTextExtentPoint(Canvas.Handle,Buffer,52,TSize(Result));

Result.X := Result.X div 52;
end;


function TMessageDlg.CreateMessageDialog: TMessageForm;
const
mcHorzMargin = 8;
mcVertMargin = 8;
mcHorzSpacing = 10;
mcVertSpacing = 10;
mcButtonWidth = 50;
mcButtonHeight = 14;
mcButtonSpacing = 4;

var
DialogUnits: TPoint;
HorzMargin, VertMargin, HorzSpacing, VertSpacing, ButtonWidth,
ButtonHeight, ButtonSpacing, ButtonCount, ButtonGroupWidth,
IconTextWidth, IconTextHeight, X, ALeft: Integer;
B, DefaultButton, CancelButton: TMsgDlgBtn;
IconID: PChar;
TextRect: TRect;
AtLeastOne,CreatedCB: Boolean;

begin
Result := TMessageForm.CreateNew(Application);

with Result do begin
Font.Assign(FFont);

MsgDlg := Self;
Modeless := Self.Modeless;
BiDiMode := Application.BiDiMode;
BorderStyle := bsDialog;
Canvas.Font := Font;
Color := Self.Color;
DialogUnits := GetAveCharSize(Canvas);
HorzMargin := MulDiv(mcHorzMargin,DialogUnits.X,4);
VertMargin := MulDiv(mcVertMargin,DialogUnits.Y,8);
HorzSpacing := MulDiv(mcHorzSpacing,DialogUnits.X,4);
VertSpacing := MulDiv(mcVertSpacing,DialogUnits.Y,8);
ButtonWidth := MulDiv(mcButtonWidth,DialogUnits.X,4);

if HelpFile <> '' then
Result.HelpFile := HelpFile;

if HelpContext > 0 then
Result.HelpContext := HelpContext;

AtLeastOne := False;

for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do begin
if B in Buttons then begin
AtLeastOne := True;

if ButtonWidths = 0 then begin
TextRect := Rect(0,0,0,0);

Windows.DrawText(Canvas.Handle,PChar(ButtonCaptions),-1,
TextRect,DT_CALCRECT or DT_LEFT or DT_SINGLELINE or DrawTextBiDiModeFlagsReadingOnly);

with TextRect do
ButtonWidths := Right - Left + 8;
end;

if ButtonWidths > ButtonWidth then
ButtonWidth := ButtonWidths;
end;
end;

if AtLeastOne then
ButtonHeight := MulDiv(mcButtonHeight,DialogUnits.Y,8)
else
ButtonHeight := 0;

ButtonSpacing := MulDiv(mcButtonSpacing,DialogUnits.X,4);

SetRect(TextRect,0,0,Screen.Width div 2,0);
DrawText(Canvas.Handle,PChar(Msg),Length(Msg)+1,TextRect,
DT_EXPANDTABS or DT_CALCRECT or DT_WORDBREAK or DrawTextBiDiModeFlagsReadingOnly);

IconID := IconIDs[DlgType];
IconTextWidth := TextRect.Right;
IconTextHeight := TextRect.Bottom;

if (IconID <> nil) or ((CustomIcon <> nil) and (CustomIcon.Handle > 0)) then begin
Inc(IconTextWidth,32 + HorzSpacing);

if IconTextHeight < 32 then
IconTextHeight := 32;
end;

ButtonCount := 0;

for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do
if B in Buttons then
Inc(ButtonCount);

ButtonGroupWidth := 0;

if ButtonCount <> 0 then
ButtonGroupWidth := ButtonWidth * ButtonCount + ButtonSpacing * (ButtonCount - 1);

if Self.CheckBox then
VertSpacing := VertSpacing + 26;

ClientWidth := Max(IconTextWidth,ButtonGroupWidth) + HorzMargin * 2;
ClientHeight := IconTextHeight + ButtonHeight + VertSpacing + VertMargin * 2;
Left := (Screen.Width div 2) - (Width div 2);
Top := (Screen.Height div 2) - (Height div 2);

if DlgType <> mtCustom then
Caption := Captions[DlgType]
else if CustomCaption <> '' then
Caption := CustomCaption
else
Caption := Application.Title;

if IconID <> nil then begin
with TImage.Create(Result) do begin
Name := 'Image';
Parent := Result;
Picture.Icon.Handle := LoadIcon(0,IconID);

SetBounds(HorzMargin,VertMargin,32,32);
end;
end else if CustomIcon <> nil then begin
with TImage.Create(Result) do begin
Name := 'Image';
Parent := Result;

Picture.Icon.Assign(CustomIcon);
SetBounds(HorzMargin,VertMargin,32,32);
end;
end;

Result.MainMsg := TLabel.Create(Result);

with MainMsg do begin
Name := 'Message';
Parent := Result;
WordWrap := True;
Caption := Msg;
BoundsRect := TextRect;
BiDiMode := Result.BiDiMode;
ALeft := IconTextWidth - TextRect.Right + HorzMargin;

if UseRightToLeftAlignment then
ALeft := Result.ClientWidth - ALeft - Width;

SetBounds(ALeft,VertMargin,TextRect.Right,TextRect.Bottom);
end;

if mbOk in Buttons then
DefaultButton := mbOk
else if mbYes in Buttons then
DefaultButton := mbYes
else
DefaultButton := mbRetry;

if mbCancel in Buttons then
CancelButton := mbCancel
else if mbNo in Buttons then
CancelButton := mbNo
else
CancelButton := mbOk;

CreatedCB := False;
X := (ClientWidth - ButtonGroupWidth) div 2;

for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do
if B in Buttons then
with TButton.Create(Result) do begin
Name := ButtonNames;
Parent := Result;
Caption := ButtonCaptions;
ModalResult := ModalResults;

Font.Assign(FButtonFont);

if B = DefaultButton then
Default := True;

if B = CancelButton then
Cancel := True;

SetBounds(X,IconTextHeight + VertMargin + VertSpacing,ButtonWidth,ButtonHeight);
Inc(X,ButtonWidth + ButtonSpacing);

if B = mbHelp then
OnClick := Result.HelpButtonClick
else if Modeless then
OnClick := Result.ButtonClick;

if Self.CheckBox and not CreatedCB then begin
CreatedCB := True;
Result.CheckBox := TCheckBox.Create(Result);
Result.CheckBox.Name := 'DontShowAgain';
Result.CheckBox.Parent := Result;
Result.CheckBox.Caption := CheckBoxCaption;

Result.CheckBox.SetBounds(12,Top - 26,Result.Canvas.TextWidth(Result.CheckBox.Caption) + 10,
Result.Canvas.TextHeight(Result.CheckBox.Caption) + 10);
end;
end;

if GaugeMaxValue > 0 then begin
Result.Gauge := TGauge.Create(Result);
Result.Gauge.Name := 'Gauge';
Result.Gauge.Parent := Result;
Result.Gauge.ForeColor := GaugeForeColor;
Result.Gauge.BackColor := GaugeBackColor;
Result.Gauge.ShowText := GaugeShowText;
Result.Gauge.BorderStyle := bsNone;
Result.Gauge.Align := alBottom;
Result.Gauge.Height := 12;
Result.Gauge.MaxValue := GaugeMaxValue;
Result.Gauge.Progress := 0;
end;

if Result.CheckBox <> nil then
Result.TabOrder := 30;

if (TimeOut > 0) and ShowCountDown then begin
TimerLabel := TLabel.Create(Result);

with TimerLabel do begin
Parent := Result;
Alignment := taRightJustify;
BiDiMode := Result.BiDiMode;

SetBounds(Result.ClientWidth - 10,Result.ClientHeight - 20,0,13);
end;
end;
end;
end;


{ TMessageDlg }

constructor TMessageDlg.Create(AOwner: TComponent);
begin
inherited Create(AOwner);

FCustomIcon := TIcon.Create;
TimeOutResult := trCancel;
CheckBoxCaption := '&Don''t show this message again.';
Buttons := [mbOk];
FTimer := TTimer.Create(Self);
FTimer.Enabled := False;
FTimer.OnTimer := TimerEvent;
GaugeBackColor := clWindow;
GaugeForeColor := clBlue;
GaugeShowText := True;
FColor := clWindow;
FFont := TFont.Create;
FButtonFont := TFont.Create;
FFont.Name := 'Tahoma';
FFont.Size := 8;
FButtonFont.Name := 'Tahoma';
FButtonFont.Size := 8;
FVersion := _VERSION;
end;

destructor TMessageDlg.Destroy;
begin
FCustomIcon.Free;
FButtonFont.Free;
FFont.Free;

inherited;
end;

procedure TMessageDlg.SetFont(const Value: TFont);
begin
FFont.Assign(Value);
end;

procedure TMessageDlg.SetButtonFont(const Value: TFont);
begin
FButtonFont.Assign(Value);
end;

procedure TMessageDlg.SetIniItem(const Value: String);
begin
if UpperCase(Value) = 'MSGDLGVALUE' then
raise Exception.Create('MsgDlgValue is reserved for internal use by this component.'#10 +
'Please select another name for the IniItem property.');

FIniItem := Value;
end;

procedure TMessageDlg.SetCustomIcon(const Value: TIcon);
begin
FCustomIcon.Assign(Value);
end;

procedure TMessageDlg.SetCheckBox(const Value: Boolean);
begin
FCheckBox := Value and not Modeless;
end;

procedure TMessageDlg.SetCheckBoxCaption(const Value: String);
begin
FCheckBoxCaption := Value;

if Value = '' then
FCheckBoxCaption := '&Don''t show this message again.';
end;

procedure TMessageDlg.ValidateTimeOutResult;
var
cButtons, cButton,cTimeOutResult: String;
B: TMsgDlgBtn;
FFirst: Boolean;

begin
if TimeOut > 0 then begin
if TimeOutResult <> trNone then begin
cTimeOutResult := GetEnumName(TypeInfo(TTimeOutResult),Ord(TimeOutResult));
cTimeOutResult := UpperCase(Copy(cTimeOutResult,3,Length(cTimeOutResult)));
cButtons := '';
FFirst := True;

for B := Low(TMsgDlgBtn) to High(TMsgDlgBtn) do begin
if B in Buttons then begin
cButton := GetEnumName(TypeInfo(TMsgDlgBtn),Ord(B));
cButton := UpperCase(Copy(cButton,3,Length(cButton)));
cButtons := cButtons + cButton;

if FFirst then begin
FFirst := False;
FTimeOutResult := TTimeOutResult(GetEnumValue(TypeInfo(TTimeOutResult),'tr' + cButton));
end;
end;
end;

end;
end;
end;

procedure TMessageDlg.SetTimeOutResult(const Value: TTimeOutResult);
begin
FTimeOutResult := Value;

ValidateTimeOutResult;
end;

procedure TMessageDlg.SetButtons(const Value: TMsgDlgButtons);
begin
FButtons := Value;

ValidateTimeOutResult;
end;

procedure TMessageDlg.SetModeless(const Value: Boolean);
begin
FModeless := Value;

if Value then
CheckBox := False;
end;

procedure TMessageDlg.TimerEvent(Sender: TObject);
begin
Dec(Seconds);

if ShowCountDown then
TimerLabel.Caption := IntToStr(Seconds);

if Seconds = 0 then
DlgForm.ModalResult := Ord(TimeOutResult);
end;

procedure TMessageDlg.IncGauge;
begin
IncGauge(1);
end;

procedure TMessageDlg.IncGauge(Value: Integer);
begin
if (DlgForm <> nil) and (DlgForm.Gauge <> nil) then
DlgForm.Gauge.Progress := DlgForm.Gauge.Progress + Value;
end;

procedure TMessageDlg.SetMsg(const Value: String);
begin
FMsg := Value;

if DlgForm <> nil then begin
DlgForm.MainMsg.Caption := Value;
end;
end;

procedure TMessageDlg.SetVersion(const Value: String);
begin
FVersion := _VERSION;
end;

function TMessageDlg.Execute(AMsg: String; ADlgType: TMsgDlgType;
AButtons: TMsgDlgButtons; AHelpContext: Integer): Integer;
begin
Msg := AMsg;
DlgType := ADlgType;
Buttons := AButtons;
HelpContext := AHelpContext;
Result := Execute;
end;

function TMessageDlg.Execute: Integer;
begin
Checked := False;

if CheckBox then begin
if not AllowBlankINI then begin
if IniFile = '' then
raise Exception.Create('IniFile property not specified');

if IniSection = '' then
raise Exception.Create('IniSection property not specified');

if IniItem = '' then
raise Exception.Create('IniItem property not specified');
end;

if (IniFile <> '') and (IniSection <> '') and (IniItem <> '') then
if UseRegistry then begin
with TRegIniFile.Create(IniFile) do begin
Checked := ReadBool(IniSection,IniItem,False);
Result := ReadInteger(IniSection,'MsgDlgValue',mrNone);

Free;
end;
end else begin
with TIniFile.Create(IniFile) do begin
Checked := ReadBool(IniSection,IniItem,False);
Result := ReadInteger(IniSection,'MsgDlgValue',mrNone);

Free;
end;
end;
end;

if not Checked then begin
DlgForm := CreateMessageDialog;
DlgForm.Position := poScreenCenter;

if TimeOut > 0 then begin
if ShowCountDown then
TimerLabel.Caption := IntToStr(TimeOut);

Seconds := TimeOut;
FTimer.Interval := 1000;
FTimer.Enabled := True;
end;

if not Modeless then begin
try
Result := DlgForm.ShowModal;

if DlgForm.CheckBox <> nil then
Checked := DlgForm.CheckBox.Checked;
finally
FreeAndNil(DlgForm);
end;

CheckCheckBox(Result);
end else begin
DlgForm.Show;
DlgForm.Refresh;
end;
end;
end;

procedure TMessageDlg.CheckCheckBox(AResult: Integer);
begin
if TimeOut > 0 then
FTimer.Enabled := False;

if CheckBox and (IniFile <> '') and (IniSection <> '') and (IniItem <> '') then
if UseRegistry then begin
with TRegIniFile.Create(IniFile) do begin
WriteBool(IniSection,IniItem,Checked);
WriteInteger(IniSection,'MsgDlgValue',AResult);
Free;
end;
end else begin
with TIniFile.Create(IniFile) do begin
WriteBool(IniSection,IniItem,Checked);
WriteInteger(IniSection,'MsgDlgValue',AResult);
Free;
end;
end;
end;

procedure TMessageDlg.Close;
begin
if DlgForm <> nil then
DlgForm.Close;
end;

procedure TMessageDlg.Hide;
begin
if DlgForm <> nil then
DlgForm.Hide;
end;

procedure TMessageDlg.Show;
begin
if DlgForm <> nil then
DlgForm.Show;
end;


{ TMsgProperty }

procedure TMsgProperty.Edit;
var
Editor: TfmMsgEditor;

begin
Editor := TfmMsgEditor.Create(Application);

try
Editor.Msg.Text := GetStrValue;

if Editor.ShowModal = mrOK then
SetStrValue(Editor.Msg.Text);
finally
Editor.Free;
end;
end;

function TMsgProperty.GetAttributes: TPropertyAttributes;
begin
Result := [paDialog,paMultiSelect,paAutoUpdate];
end;


{ TfmMsgEditor }

procedure TfmMsgEditor.FormKeyPress(Sender: TObject; var Key: Char);
begin
if Key = #27 then begin
Key := #0;

Close;
end;
end;

function TMsgProperty.GetEditLimit: Integer;
begin
Result := 10000;
end;

procedure Register;
var
TabName: String;
begin
TabName := '';

with TIniFile.Create('MSGDLG.INI') do begin
try
TabName := ReadString('MessageDlg','ControlsTab','');

if TabName = '' then
TabName := InputBox('Install TMessageDlg to','Component palette tab name','Dialogs');

if TabName = '' then
TabName := 'Dialogs';

WriteString('MessageDlg','ControlsTab',TabName);

finally
Free;
end;
end;

if TabName = '' then
TabName := 'Dialogs';

RegisterComponents(TabName,[TMessageDlg]);
RegisterPropertyEditor(TypeInfo(String),TMessageDlg,'Msg',TMsgProperty);
end;
end.
 
pims:
对不起,来这里打扰你,你给我的BAPI没有啊?
 
参照dclusr.dpk
加入需要的设计包
 
参照dclusr.dpk
加入需要的设计包
 
顶部