自己制作组件的问题

我想自己制作一个组件,可是没有头绪,谁能给我一个最简单的例子,要详细点!

12 个解决方案

#1

要完成什么功能?

用delphi的wizard自己做个按钮试试好了

最好还是拿来别人的控件源代码自己看看懂你就会了

网上控件源代码很多找个来看看就行

#2

那里有

#3

不知有没有记错, 是CSDN中的sysu(死树) 的代码

{ Tranbtn.pas }

unit Tranbtn;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, StdCtrls, ExtCtrls;

type
  BStyle = (BSnone,BsNormal,BsIe);
  TMTranBtn = class(TGraphicControl)
  private
    FBitMap : TBitmap;
    FOver : Boolean;
    Pushed : boolean;
    Fborder : BStyle;
    BRect : Trect;
    procedure SetBitMap(Value : TBitMap);
    procedure WMLButtonDown(var msg: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMLButtonUp(var msg: TWMLButtonUp); message WM_LBUTTONUP;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    function OnGlyphP(X, Y: integer): boolean;
    procedure mouseleave(var msg : tmessage); message cm_mouseleave;
    procedure mousein(var msg : tmessage); message cm_mouseenter;
    Procedure setborderstyle(value:Bstyle);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    procedure DrawTransparentBitmap (ahdc: HDC; Image: TBitmap; xStart, yStart: Word; TrCol : Tcolor);
    property BitMap : TBitMap read FBitMap write SetBitMap;
    Property OnClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property Visible;
    Property Hint;
    Property ShowHint;
    Property Border : BStyle read fborder write SetBorderStyle;
    Property Caption;
    Property Font;
  end;

procedure Register;

implementation

{TMTranBtn}
constructor TMTranBtn.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Width := 30;
Height := 30;
FBitMap := TBitMap.Create;
ControlStyle := ControlStyle - [csOpaque];
Pushed := false;
Font.name := 'Arial';
Font.size := 9;
Fborder := BsNormal;
end;

destructor TMTranBtn.Destroy;
begin
FBitMap.Free;
inherited Destroy;
end;

procedure TMTranBtn.SetBitMap(Value : TBitMap);
begin
FBitMap.Assign(Value);
invalidate;
end;

{this routine come from unit XparBmp of Michael Vincze (vincze@ti.com), I think it can be
optimized more. Will find time to check it again}
procedure TMTranBtn.DrawTransparentBitmap (ahdc: HDC; Image: TBitmap; xStart, yStart: Word; TrCol : Tcolor);
var
  TransparentColor: TColor;
  cColor          : TColorRef;
  bmAndBack,
  bmAndObject,
  bmAndMem,
  bmSave,
  bmBackOld,
  bmObjectOld,
  bmMemOld,
  bmSaveOld       : HBitmap;
  hdcMem,
  hdcBack,
  hdcObject,
  hdcTemp,
  hdcSave         : HDC;
  ptSize          : TPoint;
begin
TransparentColor := TrCol;
TransparentColor := TransparentColor or $02000000;

hdcTemp := CreateCompatibleDC (ahdc);
SelectObject (hdcTemp, Image.Handle); { select the bitmap }
ptSize.x := Image.Width;
ptSize.y := Image.Height;
DPtoLP (hdcTemp, ptSize, 1);  { convert from device logical points }
hdcBack   := CreateCompatibleDC(ahdc);
hdcObject := CreateCompatibleDC(ahdc);
hdcMem    := CreateCompatibleDC(ahdc);
hdcSave   := CreateCompatibleDC(ahdc);

bmAndBack   := CreateBitmap (ptSize.x, ptSize.y, 1, 1, nil);
bmAndObject := CreateBitmap (ptSize.x, ptSize.y, 1, 1, nil);

bmAndMem    := CreateCompatibleBitmap (ahdc, ptSize.x, ptSize.y);
bmSave      := CreateCompatibleBitmap (ahdc, ptSize.x, ptSize.y);

bmBackOld   := SelectObject (hdcBack, bmAndBack);
bmObjectOld := SelectObject (hdcObject, bmAndObject);
bmMemOld    := SelectObject (hdcMem, bmAndMem);
bmSaveOld   := SelectObject (hdcSave, bmSave);

SetMapMode (hdcTemp, GetMapMode (ahdc));
BitBlt (hdcSave, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCCOPY);
cColor := SetBkColor (hdcTemp, TransparentColor);
BitBlt (hdcObject, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCCOPY);

SetBkColor (hdcTemp, cColor);
BitBlt (hdcBack, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, NOTSRCCOPY);

BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, ahdc, xStart, yStart, SRCCOPY);
BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcObject, 0, 0, SRCAND);
BitBlt (hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcBack, 0, 0, SRCAND);
BitBlt (hdcMem, 0, 0, ptSize.x, ptSize.y, hdcTemp, 0, 0, SRCPAINT);
BitBlt (ahdc, xStart, yStart, ptSize.x, ptSize.y, hdcMem, 0, 0, SRCCOPY);
BitBlt (hdcTemp, 0, 0, ptSize.x, ptSize.y, hdcSave, 0, 0, SRCCOPY);
DeleteObject (SelectObject (hdcBack, bmBackOld));
DeleteObject (SelectObject (hdcObject, bmObjectOld));
DeleteObject (SelectObject (hdcMem, bmMemOld));
DeleteObject (SelectObject (hdcSave, bmSaveOld));
DeleteDC (hdcMem);
DeleteDC (hdcBack);
DeleteDC (hdcObject);
DeleteDC (hdcSave);
DeleteDC (hdcTemp);
end;

procedure TMTranBtn.setborderstyle(value:Bstyle);
begin
if Fborder <> value then
begin
  Fborder := value;
  Invalidate;
end;
end;

procedure TMTranBtn.Paint;
var
  ARect: TRect;
  Tmp : TBitMap;
  x,y : integer;
  text : array[0..40] of char;
  Fontheight : integer;
begin
ARect := Rect(0,0,Width,Height);
Canvas.font := font;
FontHeight := Canvas.TextHeight('W');
if not FBitMap.empty then
  begin
  x := (width - FBitMap.width) div 2;
  if caption <> '' then
    y := ((Height - FBitMap.Height- FontHeight) div 2)
  else
   y := ((Height - FBitMap.Height) div 2);
     BRect := rect(x, y, x + FBitMap.width, y + FBitMap.height);
     Tmp := TBitmap.Create;
     Tmp.Height := FBitMap.Height;
     Tmp.Width := FBitMap.Width;
     Tmp.Canvas.CopyRect(ARect, FBitmap.Canvas, ARect);
     if pushed then
      DrawTransparentBitmap( Canvas.Handle, Tmp, x +1, y+1, FBitmap.TransparentColor )
     else
      DrawTransparentBitmap( Canvas.Handle, Tmp, x, y, FBitmap.TransparentColor );
     Tmp.Free;
  end;

  if caption <> '' then
  with Canvas do
  begin
   Brush.Style := bsClear;
   with ARect do
    begin
     if Fbitmap.empty then
       Top := ((Bottom + Top) - FontHeight) shr 1
     else
       top := Brect. bottom;
      Bottom := Top + FontHeight;
      if pushed then
        begin
         top := top + 1;
         left := 2;
        end;
    end;
    StrPCopy(Text, Caption);
    DrawText(Handle, Text, StrLen(Text), ARect, (DT_EXPANDTABS or DT_center));
   end;

ARect := getclientrect;
case fborder of
BsNormal : BEGIN
            if pushed then
                frame3d(canvas, ARect ,clBtnShadow,clBtnHighlight, 1)
            else
                frame3d(canvas, ARect ,clBtnHighlight,clBtnShadow, 1);
            END;
BsIe :  Begin
         if pushed then
            frame3d(canvas, ARect ,clBtnShadow,clBtnHighlight, 1)
         else
          if Fover then
            frame3d(canvas, ARect ,clBtnHighlight,clBtnShadow, 1);
         end;
end; { case}
end;

function TMTranBtn.OnGlyphP(X, Y: integer): boolean;
begin
  Result := PtInRect({ClientRect} BRect, Point(X, Y)) and
            (FBitmap.Canvas.Pixels[X, Y] <> FBitmap.TransparentColor);
end;

procedure TMTranBtn.MouseMove(Shift: TShiftState; X, Y: Integer);

begin
  FOver := (fborder = bsnormal) or (fborder = bsie) or  OnGlyphP(X, Y);
  Inherited MouseMove(Shift, X, Y);
end;

procedure TMTranBtn.mouseleave(var msg : tmessage);
var  rc : Trect;
BEGIN
  FOver := false;
  rc := getclientrect;
  if Fborder = bsie then
    INVALIDATE;
END;

procedure TMTranBtn.mousein(var msg : tmessage);
var  rc : Trect;
BEGIN
  FOver := true;
  rc := getclientrect;
  if Fborder = bsie then
    frame3d(canvas, rc ,clBtnHighlight,clBtnShadow, 1);
END;

procedure TMTranBtn.WMLButtonDown;
begin
inherited;
  Pushed := (fborder = bsnormal) or (fborder = bsie) OR FOver;
  if pushed then
     invalidate;
end;

procedure TMTranBtn.WMLButtonUp;
begin
inherited;
if (fborder = bsnormal) or (fborder = bsie) or FOver then
    Pushed := false;
if Pushed = false then
   invalidate;
end;

procedure Register;
begin
  RegisterComponents('MyComponent', [TMTranBtn]);
end;

end.

#4

补充：是做一个透明按钮

#5

谢谢，还有再简单点的吗

我主要想了解自己制作组件的步骤，主要是必须要作的步骤，比如构造函数一定要有吗？

#6

这不是三言两语能说完的. 建议还是买本书, 实实在在的看.

#7

1. 创建一个Package, 然后加上一些单元,这些.pas文件上包含你控件的代码。
2. 用Image Editor工具创建一个图片库.dcr文件，这个文件是存放你控件的图标，记住，.dcr名一定要和单元名相同，并且.Dcr里面的图片名一定要和你的注册的类名相同，并且一定要大写。
3. Compile这个Package,然后安装就行了。

#8

下面是一个例子：
unit USoftReg;

interface

uses
  Windows, Messages, Classes, SysUtils, Registry, dialogs;

Const
    Letter76: array[0..76] of PChar = (
             '0','1','2','3','4','5','6','7','8','9',
             'A','B','C','D','E','F','G','H','I','J',
             'K','L','M','N','O','P','Q','R','S','T',
             'U','V','W','X','Y','Z','a','b','c','d',
             'e','f','g','f','i','j','k','l','m','n',
             'o','p','q','r','s','t','u','v','w','x',
             'y','z','.',',','-','(',')','/','=','!',
             '"','%','&','*',';','<','>');

Type
  TSoftWareReg = Class(TComponent)

  private
    FAllowTimes, FPeriod: integer;
    FRegName: String;
    FAvailable: Boolean;
    FirstDate: TDatetime;
    Reg: TRegistry;
    function Encrypt(TempStr: string): String;
    procedure SetAllowTime(Value: integer);
    procedure SetFreePeriod(Value: integer);
    procedure SetRegName(Value: String);
    procedure SetAvailable(Value: Boolean);
//    procedure SetDefaultName;
  protected

  public
    constructor Create(AOwner: TComponent);override;
    destructor Destroy; override;
    procedure Registried(RegUser, RegPass: String);
    function IsRegistry: boolean;
    function Isexpire(CurrentDate: TDateTime): boolean;
    function IsAllowExecuted: boolean;
    procedure SetRegistry;
  published
    property Available: Boolean read FAvailable write SetAvailable Default False;
    property AllowTimes: integer read FAllowTimes write SetAllowTime;
    property FreePeriod: integer read FPeriod write SetFreePeriod;
    property RegName: String read FRegName write SetRegName;

  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Wally', [TSoftWareReg]);
end;

constructor TSoftWareReg.Create(AOwner: TComponent);

begin
  inherited Create(AOwner);
  try
    Reg := TRegistry.Create;
    Reg.RootKey := HKEY_LOCAL_MACHINE;
  except
    Reg.Free;
  end;

end;

destructor TSoftWareReg.Destroy;
begin
  Reg.Free;
  inherited Destroy;
end;

function TSoftWareReg.Encrypt(TempStr: string): String;
var
  ReturnStr: String;
  Str1: Char;
  i, j, k, iTemp: integer;
  iFlag1, iFlag2: boolean;
begin
  ReturnStr := '';
  iFlag1 := False;
  iFlag2 := False;
  for i:=1 to Length(TempStr) do
  begin
    j := (i*i*i*i mod (i+30)) +(i*i mod(I+20)) +i*3+1;
    iTemp := Ord(TempStr[i]) +j;
    if Ord(TempStr[i]) +j >122 then
       iTemp := Ord(TempStr[i]) +j - 122;
    if iTemp < 32 then
      iTemp := iTemp +32;
    Str1 := Chr(iTemp);
    for k := 0 to 76 do
    begin
      if Str1 = Letter76[k] then
      begin
        iFlag1 := True;
        break;
      end
      else
        iFlag1 := False;
    end;
    if iFlag1 then
      ReturnStr := ReturnStr + Str1
    else
      ReturnStr := ReturnStr +'W';
    j := (i*i*i*i mod (i+30)) +(i*i mod(I+20)) +i*3+1;
    iTemp := Ord(TempStr[i]) +j;
    if Ord(TempStr[i]) +j >122 then
       iTemp := Ord(TempStr[i]) +j - 122;
    if iTemp < 32 then
      iTemp := iTemp +32;
    Str1 := Chr(iTemp);
    for k := 0 to 76 do
    begin
      if Str1 = Letter76[k] then
      begin
        iFlag2 := True;
        break;
      end
      else
        iFlag2 := False;
    end;
    if iFlag2 then
      ReturnStr := ReturnStr + Str1
    else
      ReturnStr := ReturnStr +'W'
  end;
  Result := ReturnStr;
end;

function TSoftWareReg.IsAllowExecuted: boolean;
begin

end;

function TSoftWareReg.Isexpire(CurrentDate: TDateTime): boolean;
var
  iPeriod: integer;
  dtFirstDate: TDateTime;
  rUseDate: Real;
begin
  Result := False;
  if IsRegistry then
    Result := False
  else
  begin
    try
      if Reg.KeyExists('\SOFTWARE\' +FRegName)then
      begin
        Reg.OpenKey('\SOFTWARE\' +FRegName, False);
        if Reg.ValueExists('FirstDate') then
          dtFirstDate := Reg.ReadDate('FirstDate')
        else
          Result := True;
        if Reg.ValueExists('Period') then
          iPeriod := Reg.ReadInteger('Period')
        else
          Result := True;
        rUseDate := CurrentDate - dtFirstDate;
        if round(rUseDate -iPeriod) >= 0 then
          Result := True;
      end
      else
        Result := False;
    finally
      Reg.CloseKey;
    end;
   end;
end;

function TSoftWareReg.IsRegistry: boolean;
begin
  try
    if Reg.KeyExists('\SOFTWARE\' +FRegName)then
    begin
      Reg.OpenKey('\SOFTWARE\' +FRegName, False);
      if Reg.ValueExists('Registried') then
        Result := Reg.ReadBool('Registried')
      else
        Result := False;
    end
    else
      Result := False;
  finally
    Reg.CloseKey;
  end;
end;

procedure TSoftWareReg.Registried(RegUser, RegPass: String);
var
  sCompare, s1: string;
  i: integer;
begin
  try
    if not Reg.KeyExists('\SOFTWARE\' +FRegName)then
      Reg.CreateKey('\SOFTWARE\' +FRegName);
    Reg.OpenKey('\SOFTWARE\' +FRegName, false);
    sCompare := Encrypt(trim(RegUser));
    if CompareStr(sCompare, Trim(RegPass)) = 0 then
      Reg.WriteBool('Registried', True)
  finally
    Reg.CloseKey;
  end;
end;

procedure TSoftWareReg.SetAllowTime(Value: integer);
begin
  if FAllowTimes <> 0 then
    FAllowTimes := Value
  else
    FAllowTimes := 1;
end;

procedure TSoftWareReg.SetAvailable(Value: Boolean);
begin
  FAvailable := Value;
end;

procedure TSoftWareReg.SetFreePeriod(Value: integer);
begin
  if Value <> 0 then
    FPeriod := Value
  else
    FPeriod := 30;
end;

procedure TSoftWareReg.SetRegName(Value: String);
begin
  if Value <> EmptyStr then
    FRegName := Value
  else
    FRegName := 'RegSoftWare';
end;

procedure TSoftWareReg.SetRegistry;
begin
  try
    if not Reg.KeyExists('\SOFTWARE\' +FRegName)then
    begin
      Reg.CreateKey('\SOFTWARE\' +FRegName);
      Reg.OpenKey('\SOFTWARE\' +FRegName, false);
      Reg.WriteInteger('Period', FPeriod);
      Reg.WriteInteger('AllowTimes', FAllowTimes);
      Reg.WriteBool('Registried', False);
      Reg.WriteDate('FirstDate', Date);
    end;
  finally
    Reg.CloseKey;
  end;
end;

end.

你要做以下的工作：将单元加入Package里，然后创建一个文件为USoftReg.dcr的图片库，里面有一个图片文件TSOFTWAREREG
最后Compile和Install
这个控件就产生了

#9

http://www.mycnknow.com/srindex.htm
http://kingron.myetang.com/ 的文档区、下载区、猛料区
有专门讲写控件的书

#10

谢谢

#11

http://www.csdn.net/cnshare/soft/16/16167.shtm
我以前写的很简单的组件，有代码，你可以看看

#12

老西门,你又把那颗死树的东西贴出来骗分啦???

#1