cdibcontrol.pas

Delphi控件

      raise EDIBControlError.Create('No DIB image list has been assigned.');

    S.Read(PropertyCount, SizeOf(Integer));
    GUIDStr := GUIDToString(GUID);

    for I := 0 to ImageCount - 1 do 
    begin
      with DIBImageList.DIBImages.AddTemplate(GUIDStr, I) do 
      begin
        DIBWrapper.DIB := DIB;
        S.ReadComponent(DIBWrapper);
        FIndexes.Add(Pointer(Index));
      end;
    end;

    for I := 0 to PropertyCount - 1 do 
    begin
      //Get the property name
      S.Read(PropLen, SizeOf(Integer));
      SetLength(PropName, PropLen);
      S.Read(PropName[1], PropLen);

      //Get the display name
      DisplayName := '';
      S.Read(DisplayLen, SizeOf(Integer));
      if DisplayLen > 0 then 
      begin
        SetLength(DisplayName, DisplayLen);
        S.Read(DisplayName[1], DisplayLen);
      end;

      S.Read(Index, SizeOf(Integer));
      if IsPublishedProp(Self, PropName) then 
      begin
        Index := Integer(FIndexes[Index]);
        with TDIBImageLink(GetOrdProp(Self, PropName)) do 
        begin
          DIBIndex := Index;
          if DisplayName <> '' then
            DIBImageList.DIBImages[Index].DisplayName := DisplayName;
        end;
      end;
    end;
    ReadProperties(S);
    Loaded;
  finally
    DIBWrapper.Free;
    FIndexes.Free;
  end;
end;


procedure TCustomDIBControl.SaveTemplateToFile(const Filename: TFilename);
var
  FS: TFileStream;
begin
  FS := TFileStream.Create(Filename, fmCreate);
  try
    SaveTemplateToStream(FS);
  finally
    FS.Free;
  end;
end;

procedure TCustomDIBControl.SaveTemplateToStream(const S: TStream);
var
  I, PropertyCount, ImageCount, DisplayLen, PropLen, NewIndex, Index: Integer;

  DisplayName, PropName: string;
  FIndexes: TList;

  GUID: TGUID;

  PropertyStream, ImageStream: TMemoryStream;

  DIBWrapper: TDIBWrapper;

  OrigCompressor: TAbstractDIBCompressor;
begin
  //  if DIBImageList = nil then exit;

  if CoCreateGUID(GUID) <> S_OK then
    raise EDIBControlError.Create('Could not create a GUID for your new template.');

  FIndexes := TList.Create;
  PropertyStream := TMemoryStream.Create;
  ImageStream := TMemoryStream.Create;
  DIBWrapper := TDIBWrapper.Create(Self);

  //Don't compress templates for compatibility reasons
  //other users may not have the correct decompressor
  OrigCompressor := DefaultCompressor;
  try
    DefaultCompressor := nil;

    PropertyCount := 0;
    ImageCount := 0;

    for I := 0 to FPropertyList.Count - 1 do 
    begin
      //Get the name of the property, and the INDEX
      PropName := GetPropertyName(Self, FPropertyList[I]);
      Index := TDIBImageLink(FPropertyList[I]).DIBIndex;

      if (PropName <> '') and (DIBImageList.IsIndexValid(Index)) then 
      begin
        //If it is published, and has a valid pic, we need it
        Inc(PropertyCount);

        //Write length of the property name
        PropLen := Length(PropName);
        PropertyStream.Write(PropLen, SizeOf(Integer));
        //Write the property name
        PropertyStream.Write(PropName[1], PropLen);

        //Write the length of the display name
        DisplayName := TDIBImageLink(FPropertyList[I]).DIBImageList.DIBImages
          [Index].DisplayName;
        DisplayLen := Length(DisplayName);
        PropertyStream.Write(DisplayLen, SizeOf(Integer));
        if DisplayLen > 0 then
          PropertyStream.Write(DisplayName[1], DisplayLen);

        //See if we have already written this index
        NewIndex := FIndexes.IndexOf(Pointer(Index));
        //If not, we write it
        if NewIndex = -1 then 
        begin
          Inc(ImageCount);
          NewIndex := FIndexes.add(Pointer(Index));
          DIBWrapper.DIB := DIBImageList.DIBImages[Index].DIB;
          ImageStream.WriteComponent(DIBWrapper);
        end;

        //Now write out the remapped index (NOT the original index)
        PropertyStream.Write(NewIndex, SizeOf(Integer));
      end;
    end;

    //Now we have build a property list (with remapped index) and
    //an image list, we stick it all together
    PropertyStream.Seek(0, soFromBeginning);
    ImageStream.Seek(0, soFromBeginning);

    S.Write(GUID, SizeOf(TGUID));

    S.Write(ImageCount, SizeOf(Integer));
    S.Write(PropertyCount, SizeOf(Integer));
    S.CopyFrom(ImageStream, ImageStream.Size);
    S.CopyFrom(PropertyStream, PropertyStream.Size);
    WriteProperties(S);
  finally
    DefaultCompressor := OrigCompressor;
    DIBWrapper.Free;
    PropertyStream.Free;
    ImageStream.Free;
    FIndexes.Free;
  end;
end;


procedure TCustomDIBControl.AddTemplateProperty(const Name: string);
begin
  if not IsPublishedProp(Self, Name) then
    raise EDIBControlError.Create('Class ' + ClassName + ' is trying to register ' +
      Name +' as a template property, and that property does not exist.');
      
  if not (PropType(Self, Name) in
    [tkSet, tkInteger, tkEnumeration, tkInt64, tkChar, tkString, tkWChar,
    tkLString, tkWString, tkFloat, tkClass]) then
    raise EDIBControlError.Create('Attempting to template an invalid property type.');

  if PropType(Self, Name) = tkClass then
    if TObject(GetOrdProp(Self, Name)) is TComponent then
      raise EDIBControlError.Create('Attempting to template an invalid property type.');

  FPropertyNames.Add(Name);
end;

procedure TCustomDIBControl.ReadProperties(S: TStream);
var
  nProp, I: Integer;
  FloatVal: Extended;
  SkipSize, StrSize, PropSize, OrdVal: Longint;
  PropName, StrVal: string;
  PersistentWrapper: TPersistentWrapper;
begin
  S.Read(nProp, SizeOf(Integer));

  for I := 0 to nProp - 1 do 
  begin
    //Read the property name
    S.Read(PropSize, SizeOf(Integer));
    SetLength(PropName, PropSize);
    S.Read(PropName[1], PropSize);

    //Now the skip size
    S.Read(SkipSize, SizeOf(Longint));

    if not IsPublishedProp(Self, PropName) then
      S.Seek(SkipSize, soFromCurrent)
    else
      //Now the value
      case PropType(Self, PropName) of
        tkSet,
        tkInteger,
        tkEnumeration,
        tkInt64:
          begin
            S.Read(OrdVal, SizeOf(LongInt));
            SetOrdProp(Self, PropName, OrdVal);
          end;

        tkChar,
        tkString,
        tkWChar,
        tkLString,
        tkWString:
          begin
            S.Read(StrSize, SizeOf(Integer));
            SetLength(StrVal, StrSize);
            if StrSize > 0 then
              S.Read(StrVal[1], StrSize);
            SetStrProp(Self, PropName, StrVal);
          end;

        tkFloat:
          begin
            S.Read(FloatVal, SizeOf(Extended));
            SetFloatProp(Self, PropName, FloatVal);
          end;

        tkClass:
          begin
            PersistentWrapper := TPersistentWrapper.Create(Self);
            try
              PersistentWrapper.Persistent := TPersistent(GetOrdProp(Self, PropName));
              S.ReadComponent(PersistentWrapper);
              PersistentWrapper.Persistent := nil;
            finally
              PersistentWrapper.Free;
            end;
          end;
      end;
  end;
end;

procedure TCustomDIBControl.WriteProperties(S: TStream);
var
  I: Integer;
  FloatVal: Extended;
  StrSize, PropSize, OrdVal: Longint;
  PropName, StrVal: string;
  TempStream: TMemoryStream;
  PersistentWrapper: TPersistentWrapper;
begin
  I := FPropertyNames.Count;
  S.Write(I, SizeOf(Integer));

  for I := 0 to FPropertyNames.Count - 1 do 
  begin
    PropName := FPropertyNames[I];
    PropSize := Length(PropName);

    //Write the property name first
    S.Write(PropSize, SizeOf(Integer));
    S.Write(PropName[1], PropSize);

    //Now the value
    case PropType(Self, PropName) of
      tkSet,
      tkInteger,
      tkEnumeration,
      tkInt64:
        begin
          //Skip size in case this property does not exist
          OrdVal := SizeOf(Longint);
          S.Write(OrdVal, SizeOf(LongInt));

          //The value
          OrdVal := GetOrdProp(Self, PropName);
          S.Write(OrdVal, SizeOf(Longint));
        end;

      tkChar,
      tkString,
      tkWChar,
      tkLString,
      tkWString:
        begin
          //Get the string value
          StrVal := GetStrProp(Self, PropName);
          StrSize := Length(StrVal);

          //Skip size in case this property does not exist
          OrdVal := SizeOf(Longint) + StrSize;
          S.Write(OrdVal, SizeOf(LongInt));

          //Write the string size + data
          S.Write(StrSize, SizeOf(Integer));
          if StrSize > 0 then
            S.Write(StrVal[1], StrSize);
        end;

      tkFloat:
        begin
          //Write the skip size
          OrdVal := SizeOf(Extended);
          S.Write(OrdVal, SizeOf(Longint));

          //Write the property value
          FloatVal := GetFloatProp(Self, PropName);
          S.Write(FloatVal, SizeOf(Extended));
        end;

      tkClass:
        begin
          TempStream := TMemoryStream.Create;
          PersistentWrapper := TPersistentWrapper.Create(Self);
          try
            PersistentWrapper.Persistent := TPersistent(GetOrdProp(Self, PropName));
            TempStream.WriteComponent(PersistentWrapper);
            PersistentWrapper.Persistent := nil;

            //Write the skip size
            OrdVal := TempStream.Size;
            S.Write(OrdVal, SizeOf(LongInt));

            //Write the data
            TempStream.Seek(0, soFromBeginning);
            S.CopyFrom(TempStream, TempStream.Size);
          finally
            TempStream.Free;
            PersistentWrapper.Free;
          end;
        end;
    end;
  end;
end;

function TCustomDIBControl.GetMousePosition: TPoint;
begin
  Result := Point(FMouseXPos, FMouseYPos);
end;

procedure TCustomDIBControl.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FShiftState := Shift;
  Include(FMouseButtons, Button);
  if DIBTabOrder >= 0 then SetFocus;
  inherited;
end;

procedure TCustomDIBControl.MouseUp(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FShiftState := Shift;
  Exclude(FMouseButtons, Button);
  inherited;
  if (Button = mbLeft) and (FMouseInControl) and not (FRealMouseInControl) then
    DoMouseLeave;
end;

procedure TCustomDIBControl.AfterPaint;
begin
  if Assigned(FOnPaintEnd) then FOnPaintEnd(Self);
end;

procedure TCustomDIBControl.BeforePaint;
begin
  if Assigned(FOnPaintStart) then FOnPaintStart(Self);
end;

procedure TCustomDIBControl.Invalidate;
begin
  inherited;
  if not FMovingOnly then
    FLastInvalidateTime := GetTickCount;
end;

procedure TCustomDIBControl.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  if not (Enabled) and FFocused then
    DoExit;
end;

procedure TCustomDIBControl.DoDefaultPopupMenu(const PopupMenu: TPopupMenu);
begin
end;

procedure TCustomDIBControl.ClearDefaultPopupMenu(const PopupMenu: TPopupMenu);
begin
  PopupMenu.Items.Clear;
end;

function TCustomDIBControl.GetPopupMenu: TPopupMenu;
begin
  Result := inherited GetPopupMenu;
  if Result = nil then
  begin
    ClearDefaultPopupMenu(GDefaultPopupMenu);
    DoDefaultPopupMenu(GDefaultPopupMenu);
    if GDefaultPopupMenu.Items.Count > 0 then
      Result := GDefaultPopupMenu;
  end;
end;

{ TCustomDIBFramedControl }

procedure TCustomDIBFramedControl.AfterPaint;
begin
  inherited;
  DrawBorder;
end;

procedure TCustomDIBFramedControl.BeforePaint;
begin
  inherited;
  DrawBackground;
end;

constructor TCustomDIBFramedControl.Create(AOwner: TComponent);
begin
  inherited;
  FBackgroundStyle := bsDrawSolid;
end;

destructor TCustomDIBFramedControl.Destroy;
begin
  inherited;
end;

procedure TCustomDIBFramedControl.DrawBackground;
var
  Handled: Boolean;
begin
  if BackgroundStyle = bsDrawSolid then
  begin
    Handled := False;
    if Assigned(OnDrawBackground) then OnDrawBackground(Self, Handled);
    if not Handled then ControlDIB.QuickFill(Color);
  end;
end;

procedure TCustomDIBFramedControl.DrawBorder;
var
  Handled: Boolean;
begin
  Handled := False;
  if Assigned(OnDrawBorder) then OnDrawBorder(Self, Handled);
  if not Handled and Assigned(DIBBorder) then DIBBorder.DrawTo(ControlDIB, ClientRect);
end;

function TCustomDIBFramedControl.GetBottomBorderSize: Integer;
begin
  Result := 0;
  if Assigned(OnMeasureBottomBorder) then
    OnMeasureBottomBorder(Self, Result)
  else if Assigned(DIBBorder) then Result := DIBBorder.BorderBottom.Size;
end;

function TCustomDIBFramedControl.GetLeftBorderSize: Integer;
begin
  Result := 0;
  if Assigned(OnMeasureLeftBorder) then
    OnMeasureLeftBorder(Self, Result)
  else if Assigned(DIBBorder) then Result := DIBBorder.BorderLeft.Size;
end;

function TCustomDIBFramedControl.GetRightBorderSize: Integer;
begin
  Result := 0;
  if Assigned(OnMeasureRightBorder) then
    OnMeasureRightBorder(Self, Result)
  else if Assigned(DIBBorder) then Result := DIBBorder.BorderRight.Size;
end;

function TCustomDIBFramedControl.GetTopBorderSize: Integer;
begin
  Result := 0;
  if Assigned(OnMeasureTopBorder) then
    OnMeasureTopBorder(Self, Result)
  else if Assigned(DIBBorder) then Result := DIBBorder.BorderTop.Size;
end;

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

procedure TCustomDIBFramedControl.SetBackgroundStyle(const Value: TDIBBackgroundStyle);
begin
  FBackgroundStyle := Value;
  Invalidate;
end;

procedure TCustomDIBFramedControl.SetDIBBorder(const Value: TDIBBorder);
begin
  if DIBBorder <> nil then DIBBorder.RemoveFreeNotification(Self);
  FDIBBorder := Value;
  if DIBBorder <> nil then DIBBorder.FreeNotification(Self);
  Invalidate;
end;

initialization
  GDefaultPopupMenu := TPopupMenu.Create(nil);
finalization
  FreeAndNil(GDefaultPopupMenu);
end.