cximage.pas

来自「胜天进销存源码,国产优秀的进销存」· PAS 代码 · 共 1,762 行 · 第 1/4 页

    CalcRect := R;
    Exit;
  end;
  CalcRect.TopLeft := R.TopLeft;
  W1 := R.Right - R.Left;
  H1 := R.Bottom - R.Top;
  if W / H > W1 / H1 then
  begin
    CalcRect.Right := R.Right;
    CalcRect.Bottom := CalcRect.Top + (W1 * H div W);
  end
  else
  begin
    CalcRect.Bottom := R.Bottom;
    CalcRect.Right := CalcRect.Left + (H1 * W div H);
  end;
end;

function IsPictureEmpty(APicture: TPicture): Boolean;
begin
  Result := not Assigned(APicture.Graphic) or APicture.Graphic.Empty;
end;

procedure LoadPicture(APicture: TPicture; AGraphicClass: TGraphicClass;
  const AValue: Variant);
{ Paradox graphic BLOB header - see DB.pas}
type
  TGraphicHeader = record
    Count: Word;                { Fixed at 1 }
    HType: Word;                { Fixed at $0100 }
    Size: Longint;              { Size not including header }
  end;
var
  AGraphic: TGraphic;
  AHeader: TGraphicHeader;
  ASize: Longint;
  AStream: TMemoryStream;
begin
  if VarType(AValue) = varString then // Field.Value -> stored as string
  begin
    AStream := TMemoryStream.Create;
    try
      ASize := Length(AnsiString(AValue));
      if ASize >= SizeOf(AHeader) then
      begin
        TMemoryStreamAccess(AStream).SetPointer(@VarToStr(AValue)[1], ASize);
        AStream.Position := 0;
        AStream.Read(AHeader, SizeOf(AHeader));
        if (AHeader.Count <> 1) or (AHeader.HType <> $0100) or
          (AHeader.Size <> ASize - SizeOf(AHeader)) then
          AStream.Position := 0;
      end;
      if AStream.Size > 0 then
        try
          if AGraphicClass = nil then
            APicture.Bitmap.LoadFromStream(AStream)
          else
          begin
            AGraphic := {$IFNDEF DELPHI6}TDummyGraphicClass{$ENDIF}(AGraphicClass).Create;
            try
              AGraphic.LoadFromStream(AStream);
              APicture.Graphic := AGraphic;
            finally
              AGraphic.Free;
            end;
          end;
        except
          APicture.Assign(nil);
        end
      else
        APicture.Assign(nil);
    finally
      AStream.Free;
    end;
  end
  else
    APicture.Assign(nil);
end;

procedure SavePicture(APicture: TPicture; var AValue: AnsiString);
var
  AStream: TMemoryStream;
begin
  if not Assigned(APicture) or IsPictureEmpty(APicture) then
    AValue := ''
  else
  begin
    AStream := TMemoryStream.Create;
    try
      APicture.Graphic.SaveToStream(AStream);
      AStream.Position := 0;
      SetLength(AValue, AStream.Size);
      AStream.ReadBuffer(AValue[1], AStream.Size);
    finally
      AStream.Free;
    end;
  end;
end;

{ TcxPopupMenuLayout }

constructor TcxPopupMenuLayout.Create(AImage: TcxCustomImage);
begin
  inherited Create;
  FImage := AImage;
  FMenuItems := [pmiCut, pmiCopy, pmiPaste, pmiDelete, pmiLoad, pmiSave];
end;

destructor TcxPopupMenuLayout.Destroy;
begin
  if FCustomMenuItemGlyph <> nil then FCustomMenuItemGlyph.Free;
  inherited Destroy;
end;

function TcxPopupMenuLayout.GetCustomMenuItemGlyph: TBitmap;
begin
  if FCustomMenuItemGlyph = nil then
    FCustomMenuItemGlyph := TBitmap.Create;
  Result := FCustomMenuItemGlyph;
end;

procedure TcxPopupMenuLayout.SetCustomMenuItemGlyph(Value: TBitmap);
begin
  if (Value = nil) then
  begin
    FCustomMenuItemGlyph.Free;
    FCustomMenuItemGlyph := nil;
  end
  else
    CustomMenuItemGlyph.Assign(Value);
end;

procedure TcxPopupMenuLayout.Assign(Source: TPersistent);
begin
  if Source is TcxPopupMenuLayout then
    with TcxPopupMenuLayout(Source) do
    begin
      Self.MenuItems := MenuItems;
      Self.CustomMenuItemCaption := CustomMenuItemCaption;
      Self.CustomMenuItemGlyph.Assign(CustomMenuItemGlyph);
    end
  else
    inherited Assign(Source);
end;

{ TcxCustomImageProperties }

constructor TcxCustomImageProperties.Create(AOwner: TPersistent);
begin
  inherited Create(AOwner);
  FPopupMenuLayout := TcxPopupMenuLayout.Create(nil);
  FCenter := True;
  FDefaultHeight := cxImageDefaultInplaceHeight;
  FGraphicTransparency := gtDefault;
  FProportional := True;
  FShowFocusRect := True;
  FStretch := False;
  FGraphicClass := GetDefaultGraphicClass;
end;

destructor TcxCustomImageProperties.Destroy;
begin
  FPopupMenuLayout.Free;
  inherited Destroy;
end;

function TcxCustomImageProperties.GetGraphicClassName: string;
begin
  if FGraphicClass = nil then
    Result := ''
  else
    Result := FGraphicClass.ClassName;
end;

function TcxCustomImageProperties.IsGraphicClassNameStored: Boolean;
begin
  Result := GraphicClass <> GetDefaultGraphicClass;
end;

procedure TcxCustomImageProperties.ReadIsGraphicClassNameEmpty(Reader: TReader);
begin
  Reader.ReadBoolean;
  GraphicClassName := '';
end;

procedure TcxCustomImageProperties.SetCaption(const Value: string);
begin
  if FCaption <> Value then
  begin
    FCaption := Value;
    Changed;
  end;
end;

procedure TcxCustomImageProperties.SetCenter(Value: Boolean);
begin
  if FCenter <> Value then
  begin
    FCenter := Value;
    Changed;
  end;
end;

procedure TcxCustomImageProperties.SetGraphicClass(
  const Value: TGraphicClass);
begin
  if FGraphicClass <> Value then
  begin
    FGraphicClass := Value;
    Changed;
  end;
end;

procedure TcxCustomImageProperties.SetGraphicClassName(
  const Value: string);
var
  AGraphicClass: TGraphicClass;
begin
  if Value = '' then
    GraphicClass := nil
  else
  begin
    AGraphicClass := GetGraphicClassByName(Value);
    if AGraphicClass <> nil then
      GraphicClass := AGraphicClass;
  end;
end;

procedure TcxCustomImageProperties.SetGraphicTransparency(
  Value: TcxImageTransparency);
begin
  if FGraphicTransparency <> Value then
  begin
    FGraphicTransparency := Value;
    Changed;
  end;
end;

procedure TcxCustomImageProperties.SetPopupMenuLayout(
  Value: TcxPopupMenuLayout);
begin
  FPopupMenuLayout.Assign(Value);
end;

procedure TcxCustomImageProperties.SetProportional(AValue: Boolean);
begin
  if AValue <> FProportional then
  begin
    FProportional := AValue;
    Changed;
  end;
end;

procedure TcxCustomImageProperties.SetShowFocusRect(Value: Boolean);
begin
  if FShowFocusRect <> Value then
  begin
    FShowFocusRect := Value;
    Changed;
  end;
end;

procedure TcxCustomImageProperties.SetStretch(Value: Boolean);
begin
  if FStretch <> Value then
  begin
    FStretch := Value;
    Changed;
  end;
end;

procedure TcxCustomImageProperties.WriteIsGraphicClassNameEmpty(Writer: TWriter);
begin
  Writer.WriteBoolean(True);
end;

function TcxCustomImageProperties.CanValidate: Boolean;
begin
  Result := True;
end;

procedure TcxCustomImageProperties.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('IsGraphicClassNameEmpty', ReadIsGraphicClassNameEmpty,
    WriteIsGraphicClassNameEmpty, GraphicClassName = '');
end;

function TcxCustomImageProperties.IsDesigning: Boolean;
var
  AOwner: TPersistent;
begin
  AOwner := GetOwner;
  Result := (AOwner is TComponent) and
    (csDesigning in (AOwner as TComponent).ComponentState);
end;

function TcxCustomImageProperties.GetDefaultGraphicClass: TGraphicClass;
begin
  if GetRegisteredGraphicClasses.Count > 0 then
    Result := TGraphicClass(GetRegisteredGraphicClasses[0])
  else
    Result := nil;
end;

class function TcxCustomImageProperties.GetViewDataClass: TcxCustomEditViewDataClass;
begin
  Result := TcxImageViewData;
end;

procedure TcxCustomImageProperties.Assign(Source: TPersistent);
begin
  if Source is TcxCustomImageProperties then
  begin
    BeginUpdate;
    try
      inherited Assign(Source);
      with TcxCustomImageProperties(Source) do
      begin
        Self.Caption := Caption;
        Self.Center := Center;
        Self.CustomFilter := CustomFilter;
        Self.GraphicClass := GraphicClass;
        Self.GraphicTransparency := GraphicTransparency;
        Self.PopupMenuLayout := PopupMenuLayout;
        Self.ShowFocusRect := ShowFocusRect;
        Self.Proportional := Proportional;
        Self.Stretch := Stretch;
        Self.OnAssignPicture := OnAssignPicture;
        Self.OnCustomClick := OnCustomClick;
        Self.OnGetGraphicClass := OnGetGraphicClass;
      end;
    finally
      EndUpdate
    end
  end  
  else
    inherited Assign(Source);
end;

class function TcxCustomImageProperties.GetContainerClass: TcxContainerClass;
begin
  Result := TcxImage;
end;

function TcxCustomImageProperties.GetDisplayText(const AEditValue: TcxEditValue;
  AFullText: Boolean = False; AIsInplace: Boolean = True): WideString;
begin
  if VarIsNull(AEditValue) then Result := '' else Result := Caption;
end;

function TcxCustomImageProperties.GetEditValueSource(AEditFocused: Boolean): TcxDataEditValueSource;
begin
  Result := evsValue;
end;

function TcxCustomImageProperties.GetGraphicClass(AItem: TObject;
  ARecordIndex: Integer; APastingFromClipboard: Boolean = False): TGraphicClass;
begin
  Result := FGraphicClass;
  if Result = nil then
  begin
    if APastingFromClipboard then
      Result := TBitmap;
    if Assigned(FOnGetGraphicClass) then
      FOnGetGraphicClass(AItem, ARecordIndex, APastingFromClipboard, Result);
  end;
end;

function TcxCustomImageProperties.GetSpecialFeatures: TcxEditSpecialFeatures;
begin
  Result := inherited GetSpecialFeatures + [esfBlobEditValue];
end;

function TcxCustomImageProperties.GetSupportedOperations: TcxEditSupportedOperations;
begin
  Result := inherited GetSupportedOperations + [esoAutoHeight, esoEditing];
end;

class function TcxCustomImageProperties.GetViewInfoClass: TcxContainerViewInfoClass;
begin
  Result := TcxImageViewInfo;
end;

function TcxCustomImageProperties.IsResetEditClass: Boolean;
begin
  Result := True;
end;

procedure TcxCustomImageProperties.ValidateDisplayValue(var DisplayValue: TcxEditValue;
  var ErrorText: TCaption; var Error: Boolean; AEdit: TcxCustomEdit);
begin
  with TcxCustomImage(AEdit) do
  begin
    LockEditValueChanging(True);
    try
      DoOnAssignPicture;
      SaveModified;
      try
        EditModified := False;
        DoEditing;
      finally
        RestoreModified;
      end;
    finally
      LockEditValueChanging(False);
    end;
  end;
end;

{ TcxCustomImage }

destructor TcxCustomImage.Destroy;
begin
  if FEditPopupMenu <> nil then FEditPopupMenu.Free;
  FPicture.Free;
  inherited Destroy;
end;

procedure TcxCustomImage.EditAndClear;
begin
  if DoEditing then
    FPicture.Graphic := nil;
end;

procedure TcxCustomImage.EditPopupMenuClick(Sender: TObject);
begin
  MenuItemClick(Sender, TcxPopupMenuItem(Integer(TMenuItem(Sender).Tag)));
end;

{$IFDEF CBUILDER10}
function TcxCustomImage.GetPicture: TPicture;
begin
  Result := FPicture;
end;
{$ENDIF}

function TcxCustomImage.GetProperties: TcxCustomImageProperties;
begin
  Result := TcxCustomImageProperties(FProperties);
end;