cdibcontrol.pas

Delphi控件

    Form := GetParentForm(Self);
    if (Form <> nil) and Form.IsShortCut(Message) then Exit;
  end;
  with Message do
    if SendAppMessage(CM_APPKEYDOWN, CharCode, KeyData) <> 0 then Exit;
  Result := False;
end;

procedure TCustomDIBControl.SetBounds(aLeft, aTop, aWidth, aHeight: Integer);
var
  X, XDelta, YDelta: Integer;
begin
  if FAlreadyMoving then exit;
  //  if (aLeft=Left) and (aTop=Top) and (aWidth=Width) and (aHeight=Height) then exit;

  FMovingOnly := (aWidth = Width) and (aHeight = Height);
  try
    FAlreadyMoving := True;
    XDelta := aLeft - Left;
    YDelta := aTop - Top;

    inherited;

    //Move any dependent children
    if (XDelta <> 0) or (YDelta <> 0) then
      for X := 0 to FChildren.Count - 1 do
        if FChildren[X].Control <> nil then with FChildren[X].Control do
            SetBounds(Left + XDelta, Top + YDelta, Width, Height);
  finally
    FAlreadyMoving := False;
    FMovingOnly := False;
  end;
end;

procedure TCustomDIBControl.SetParent(AParent: TWinControl);
var
  X: Integer;
begin
  if aParent <> nil then 
  begin
    if not (AParent is TCustomDIBContainer) then
      for X := 0 to AParent.ComponentCount - 1 do
        if AParent.Components[X] is TCustomDIBContainer then 
        begin
          AParent := TWinControl(AParent.Components[X]);
          Break;
        end;
    if not (AParent is TCustomDIBContainer) then
      raise Exception.Create('Parent must be a TDIBContainer');
  end;
  inherited;
  DIBTabOrder := FTabOrder;
end;

procedure TCustomDIBControl.WMPAINT(var Message: TMessage);
var
  SrcX, SrcY, DstX, DstY: Integer;
begin
  FCanvas.Lock;
  try
    try
      DstX := 0;
      DstY := 0;
      SrcX := Left;
      SrcY := Top;

      if SrcX < 0 then
      begin
        DstX := Abs(SrcX);
        SrcX := 0;
      end;
      if SrcY < 0 then
      begin
        DstY := Abs(SrcY);
        SrcY := 0;
      end;

      TCustomDIBContainer(Parent).DIB.Draw(DstX, DstY, Width, Height,
        ControlDIB, SrcX, SrcY);
      Canvas.handle := FControlDIB.handle;
      FControlDIB.ClipRect := ClientRect;
      BeforePaint;
      Paint;
      AfterPaint;

      if csDesigning in ComponentState then with canvas do 
        begin
          Pen.color := clBlack;
          Pen.Style := psDash;
          Brush.Style := bsClear;
          Rectangle(0, 0, Width, Height);
        end;

      with THackAbstractSuperDIB(ControlDIB) do 
      begin
        Opacity := Self.Opacity;
        Draw(Self.Left, Self.Top, Width, Height, TCustomDIBContainer(Parent).DIB, 0, 0);
      end;
    finally
      FCanvas.Handle := 0;
    end;
  finally
    FCanvas.Unlock;
  end;
end;

function TCustomDIBControl.GetContainer: TCustomDIBContainer;
begin
  Result := TCustomDIBContainer(Parent);
end;

procedure TCustomDIBControl.WndProc(var Message: TMessage);
var
  Handled: Boolean;
begin
  if (csDesigning in ComponentState) then 
  begin
    inherited;
    exit;
  end;

  if Assigned(FDIBFeatures) then 
  begin
    Handled := False;
    FDIBFeatures.WndProc(Message, Handled);
  end;

  if Message.Msg = WM_LButtonDown then 
  begin
    FLastMouse := Message;
    if MouseRepeat and not FTimer.Enabled then 
    begin
      FTimer.Interval := MouseRepeatInterval;
      FTimer.Enabled := True;
    end;
  end;


  if Message.Msg = WM_MouseMove then 
  begin
    FLastMouse.WParam := Message.WParam;
    FLastMouse.LParam := Message.LParam;
    FMouseXPos := TWMMouse(Message).XPos;
    FMouseYPos := TWMMouse(Message).YPos;
    if FRealMouseInControl and not MouseInControl then Perform(CM_MouseEnter, 0, 0);
  end;

  if Message.Msg = WM_LButtonUp then
  begin
    FTimer.Enabled := False;
    if FMouseInControl and not FRealMouseInControl then Perform(CM_MouseLeave, 0, 0);
  end;

  if Message.Msg = CM_MouseEnter then 
  begin
    DoMouseEnter;
    if MouseCapture and MouseRepeat then FTimer.Enabled := True;
    if MouseCapture then exit;
  end;

  if Message.Msg = CM_MouseLeave then 
  begin
    FTimer.Enabled := False;
    DoMouseLeave;
  end;

  if not Handled then inherited;
end;

procedure TCustomDIBControl.SetOpacity(const Value: Byte);
begin
  if Value = FOpacity then exit;
  FOpacity := Value;
  Invalidate;
end;

procedure TCustomDIBControl.Paint;
begin
  if Assigned(OnPaint) then OnPaint(Self);
end;

procedure TCustomDIBControl.RepeatMessage(Sender: TObject);
begin
  if FStoppingRepeat then 
  begin
    FStoppingRepeat := False;
    FTimer.Enabled := False;
  end 
  else
    with FLastMouse do
      Perform(Msg, WParam, lParam);
end;

procedure TCustomDIBControl.Notification(AComponent: TComponent;
  Operation: TOperation);
var
  X: Integer;
begin
  inherited;
  if (AComponent = Self) or (csDestroying in ComponentState) then exit;
  if Operation = opRemove then
    for X := Children.Count - 1 downto 0 do
      if Children[X].Control = AComponent then
        FChildren[X].Free;
end;

procedure TCustomDIBControl.DoMouseEnter;
var
  NeedEnter: Boolean;
begin
  NeedEnter := not (Focused or MouseInControl);

  FRealMouseInControl := True;
  FMouseInControl := True;
  if NeedEnter then DoAnyEnter;
  if Assigned(FOnMouseEnter) then FOnMouseEnter(Self);
end;

procedure TCustomDIBControl.DoMouseLeave;
begin
  FRealMouseInControl := False;
  if MouseCapture then exit;
  FMouseInControl := False;
  if Assigned(FOnMouseLeave) then FOnMouseLeave(Self);

  if not (Focused or MouseInControl) then DoAnyLeave;
end;

procedure TCustomDIBControl.StopRepeating;
begin
  FStoppingRepeat := True;
end;

procedure TCustomDIBControl.AlterUpdateRect(var R: TRect);
begin
end;

procedure TCustomDIBControl.SetTabOrder(const Value: TTabOrder);
begin
  if (Container = nil) or (csLoading in ComponentState) then
    FTabOrder := Value
  else 
  begin
    Container.DIBSetTabOrder(Self, Value);
    FTabOrder := GetTabOrder;
  end;
end;


function TCustomDIBControl.GetTabOrder: TTabOrder;
begin
  Result := Container.DIBGetTabOrder(Self);
end;

procedure TCustomDIBControl.SetFocus;
begin
  Perform(WM_SetFocus, 0, 0);
end;

procedure TCustomDIBControl.WMKillFocus(var Message: TMessage);
begin
  DoExit;
end;

procedure TCustomDIBControl.WMSetFocus(var Message: TMessage);
begin
  if Enabled and not Focused then DoEnter;
end;

procedure TCustomDIBControl.DoEnter;
var
  NeedEnter: Boolean;
begin
  NeedEnter := not (Focused or MouseInControl);

  FFocused := True;
  Container.DIBFocusControl(Self);
  Container.SetFocus;
  if NeedEnter then DoAnyEnter;
  if Assigned(FOnEnter) then FOnEnter(Self);
end;

procedure TCustomDIBControl.DoExit;
begin
  FFocused := False;
  if Assigned(FOnExit) then FOnExit(Self);
  if not (Focused or MouseInControl) then DoAnyLeave;
end;

procedure TCustomDIBControl.WMKeyDown(var Message: TWMKey);
begin
  if not DoKeyDown(Message) then inherited;
end;

procedure TCustomDIBControl.WMKeyUp(var Message: TWMKey);
begin
  if not DoKeyUp(Message) then inherited;
end;

function TCustomDIBControl.DoKeyDown(var Message: TWMKey): Boolean;
var
  Form: TCustomForm;
begin
  Result := True;
  Form := GetParentForm(Self);
  if (Form <> nil) and Form.KeyPreview and
    THackWinControl(Form).DoKeyDown(Message) then Exit;
  with Message do
  begin
    FShiftState := KeyDataToShiftState(KeyData);
    if not (csNoStdEvents in ControlStyle) then
    begin
      KeyDown(CharCode, FShiftState);
      if CharCode = 0 then Exit;
    end;
  end;
  Result := False;
end;

function TCustomDIBControl.DoKeyPress(var Message: TWMKey): Boolean;
var
  Form: TCustomForm;
  Ch: Char;
begin
  Result := True;
  Form := GetParentForm(Self);
  if (Form <> nil) and Form.KeyPreview and
    THackWinControl(Form).DoKeyPress(Message) then Exit;
  if not (csNoStdEvents in ControlStyle) then
    with Message do
    begin
      Ch := Char(CharCode);
      KeyPress(Ch);
      CharCode := Word(Ch);
      if Char(CharCode) = #0 then Exit;
    end;
  Result := False;
end;

function TCustomDIBControl.DoKeyUp(var Message: TWMKey): Boolean;
var
  Form: TCustomForm;
begin
  Result := True;
  Form := GetParentForm(Self);
  if (Form <> nil) and Form.KeyPreview and
    THackWinControl(Form).DoKeyUp(Message) then Exit;
  with Message do
  begin
    FShiftState := KeyDataToShiftState(KeyData);
    if not (csNoStdEvents in ControlStyle) then
    begin
      KeyUp(CharCode, FShiftState);
      if CharCode = 0 then Exit;
    end;
  end;
  Result := False;
end;

procedure TCustomDIBControl.WMChar(var Message: TWMKey);
begin
  if not DoKeyPress(Message) then inherited;
end;

procedure TCustomDIBControl.KeyDown(var Key: Word; Shift: TShiftState);
begin
  if Assigned(FOnKeyDown) then FOnKeyDown(Self, Key, Shift);
end;

procedure TCustomDIBControl.KeyPress(var Key: Char);
begin
  if Assigned(FOnKeyPress) then FOnKeyPress(Self, Key);
end;

procedure TCustomDIBControl.KeyUp(var Key: Word; Shift: TShiftState);
begin
  if Assigned(FOnKeyUp) then FOnKeyUp(Self, Key, Shift);
end;

procedure TCustomDIBControl.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
  with Message do 
  begin
    Result := 0;
    if wkAll in WantedKeys then
      Result := DLGC_WANTALLKEYS
    else 
    begin
      if wkTab in WantedKeys then Result := Result or DLGC_WANTTab;
      if wkArrows in WantedKeys then Result := Result or DLGC_WANTArrows;
    end;
  end;
end;

procedure TCustomDIBControl.CMDialogChar(var Message: TCMDialogChar);
begin
  FShiftState := KeyDataToShiftState(Message.KeyData);

  if (Message.CharCode = Word(FAccelerator)) and
    Enabled and Visible and (ssAlt in FShiftState) and Parent.CanFocus then
  begin
    Click;
    Message.Result := 0;
  end 
  else
    inherited;
end;

procedure TCustomDIBControl.DoAnyEnter;
begin
end;

procedure TCustomDIBControl.DoAnyLeave;
begin
end;

procedure TCustomDIBControl.Click;
begin
  inherited;
  if (DIBTabOrder > -1) and not Focused then SetFocus;
end;

procedure TCustomDIBControl.DoImageChanged(Sender: TObject; Index: Integer;
  Operation: TDIBOperation);
begin
  if not (csDestroying in ComponentState) then
    ImageChanged(Index, Operation);
end;

procedure TCustomDIBControl.ImageChanged(Index: Integer; Operation: TDIBOperation);
begin
end;

function TCustomDIBControl.IsMouseRepeating: Boolean;
begin
  Result := FTimer.Enabled;
end;

procedure TCustomDIBControl.AddIndexProperty(var Index: TDIBImageLink);
begin
  Index := TDIBImageLink.Create(Self);
  FPropertyList.Add(Index);
  Index.OnImageChanged := DoImageChanged;
end;

procedure TCustomDIBControl.SetDIBImageList(const Value: TCustomDIBImageList);
var
  X: Integer;
begin
  if FDIBImageList <> nil then FDIBImageList.RemoveFreeNotification(Self);
  FDIBImageList := Value;
  for X := 0 to FPropertyList.Count - 1 do
    TDIBImageLink(FPropertyList[X]).DIBImageList := Value;
  if Value <> nil then
    Value.FreeNotification(Self);
end;


{
The format for a template should be
GUID
NumberOfImages : Integer;
NumberOfProperties : Integer;
-for each image-
  LengthOfDisplayName : Integer;
  DisplayName : PChar;
  LengthOfPropertyName : Integer;
  PropertyName : PChar;
  DIB.SaveDataToStream
-end--
-for each property-
  NewIndexNumber : Integer;
-end--
NumberOfClassProperties : Integer;
--for each property--
  LengthOfPropName : Integer;
  PropName : PChar;
  SkipSize : Integer;  //if this property does not exist
  Data : Binary
--end--
CUSTOM DATA GOES HERE

}

procedure TCustomDIBControl.LoadTemplateFromFile(const Filename: TFilename);
var
  FS: TFileStream;
begin
  FS := TFileStream.Create(Filename, fmOpenRead);
  try
    LoadTemplateFromStream(FS);
  finally
    FS.Free;
  end;
end;

procedure TCustomDIBControl.LoadTemplateFromStream(const S: TStream);
var
  I, Index, DisplayLen, PropLen, PropertyCount, ImageCount: Integer;
  DisplayName, PropName: string;

  GUID: TGUID;
  GUIDStr: string;

  FIndexes: TList;
  DIBWrapper: TDIBWrapper;
begin
  FIndexes := TList.Create;
  DIBWrapper := TDIBWrapper.Create(Self);
  try
    S.Read(GUID, SizeOf(TGUID));

    S.Read(ImageCount, SizeOf(Integer));
    if (ImageCount > 0) and not Assigned(DIBImageList) then