vrcontrols.pas

作工控的好控件

end;

procedure TVrGraphicControl.UpdateControlCanvas;
begin
  if not Loading then
    if FUpdateCount = 0 then Repaint;
end;

procedure TVrGraphicControl.BeginUpdate;
begin
  Inc(FUpdateCount);
end;

procedure TVrGraphicControl.EndUpdate;
begin
  Dec(FUpdateCount);
  UpdateControlCanvas;
end;

{ TVrGraphicImageControl }

constructor TVrGraphicImageControl.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FOverlay := TBitmap.Create;
  FRefreshOverlay := True;
  FBitmapImage := TBitmap.Create;
  FTransparent := false;
  DestCanvas := Self.Canvas;
end;

destructor TVrGraphicImageControl.Destroy;
begin
  FOverlay.Free;
  FBitmapImage.Free;
  inherited Destroy;
end;

procedure TVrGraphicImageControl.WMPaint(var Message: TWMPaint);
begin
  if Message.DC <> 0 then
  begin
    Canvas.Lock;
    BitmapCanvas.Lock;
    try
      Canvas.Handle := Message.DC;
      try
        Paint;
      finally
        Canvas.Handle := 0;
      end;
    finally
      BitmapCanvas.Unlock;
      Canvas.Unlock;
    end;
  end;
end;

procedure TVrGraphicImageControl.UpdateControlCanvas;
begin
  if (not Designing) then
    if (Transparent) and (not FOverlay.Empty) then
    begin
      FRefreshOverlay := false;
      ControlStyle := ControlStyle + [csOpaque];
    end;
  inherited UpdateControlCanvas;
end;

procedure TVrGraphicImageControl.CopyParentImage;
var
  DC: HDC;
  X, Y, W, H: Integer;
  P: TPoint;
begin
  FOverlay.Width := Self.Width;
  FOverlay.Height := Self.Height;
  DC := GetDC(Parent.Handle);
  try
    with Self.Canvas do
    begin
      X := ClipRect.Left;
      Y := ClipRect.Top;
      W := WidthOf(ClipRect);
      H := HeightOf(ClipRect);
      P := Point(X, Y);
      P := Parent.ScreenToClient(ClientToScreen(P));
    end;
    BitBlt(FOverlay.Canvas.Handle, X, Y, W, H, DC, P.X, P.Y, SRCCOPY);
  finally
    ReleaseDC(Parent.Handle, DC);
  end;
end;

procedure TVrGraphicImageControl.CopyOverlayImage;
begin
  BitBlt(BitmapCanvas.Handle, 0, 0, BitmapImage.Width, BitmapImage.Height,
    FOverlay.Canvas.Handle, 0, 0, SRCCOPY);
end;

procedure TVrGraphicImageControl.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  with FBitmapImage do
  begin
    Width := AWidth;
    Height := AHeight;
  end;
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;

procedure TVrGraphicImageControl.SetTransparent(Value: Boolean);
begin
  if FTransparent <> Value then
  begin
    FTransparent := Value;
    if Value then ControlStyle := ControlStyle - [csOpaque]
    else ControlStyle := ControlStyle + [csOpaque];
    if Designing then Invalidate
    else UpdateControlCanvas;
  end;
end;

procedure TVrGraphicImageControl.ClearBitmapCanvas;
begin
  with FBitmapImage do
  begin
    Canvas.Brush.Style := bsSolid;
    if FTransparent then
    begin
      if FRefreshOverlay then CopyParentImage;
      CopyOverlayImage;
    end
    else
    begin
      Canvas.Brush.Color := Self.Color;
      Canvas.FillRect(Bounds(0, 0, Width, Height));
    end;
  end;
end;

procedure TVrGraphicImageControl.Paint;
begin
  BitBlt(Canvas.Handle, 0, 0, Width, Height,
    BitmapCanvas.Handle, 0, 0, SRCCOPY);
  if Transparent then
  begin
    FRefreshOverlay := True;
    ControlStyle := ControlStyle - [csOpaque];
  end;
end;

function TVrGraphicImageControl.GetBitmapCanvas: TCanvas;
begin
  Result := FBitmapImage.Canvas;
end;

{ TVrHyperLinkControl }

procedure TVrHyperLinkControl.MouseEnter;
begin
  if Assigned(FOnMouseEnter) then
    FOnMouseEnter(Self);
end;

procedure TVrHyperLinkControl.MouseLeave;
begin
  if Assigned(FOnMouseLeave) then
    FOnMouseLeave(Self);
end;

procedure TVrHyperLinkControl.CMMouseEnter(var Message: TMessage);
begin
  inherited;
  MouseEnter;
end;

procedure TVrHyperLinkControl.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  MouseLeave;
end;

{ TVrSharedComponent }

constructor TVrSharedComponent.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FClients := TList.Create;
end;

destructor TVrSharedComponent.Destroy;
begin
  while FClients.Count > 0 do
    RemoveLink(TVrChangeLink(FClients.Last));
  FClients.Free;
  inherited Destroy;
end;

procedure TVrSharedComponent.NotifyClients;
var
  I: Integer;
begin
  for I := 0 to FClients.Count - 1 do
    TVrChangeLink(FClients[I]).Change;
end;

procedure TVrSharedComponent.InsertLink(Value: TVrChangeLink);
begin
  Value.Sender := Self;
  FClients.Add(Value);
end;

procedure TVrSharedComponent.RemoveLink(Value: TVrChangeLink);
var
  I: Integer;
begin
  I := FClients.IndexOf(Value);
  if I <> -1 then
  begin
    Value.Sender := nil;
    FClients.Delete(I);
  end;
end;

{ TVrChangeLink }

destructor TVrChangeLink.Destroy;
begin
  if Sender <> nil then
    Sender.RemoveLink(Self);
  inherited Destroy;
end;

procedure TVrChangeLink.Change;
begin
  if Assigned(FOnChange) then FOnChange(Sender);
end;

{ TVrCustomThumb }

{constructor TVrCustomThumb.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csOpaque];
  FGlyph := TBitmap.Create;
  FTransparent := True;
  FThumbStates := 1;
end;

destructor TVrCustomThumb.Destroy;
begin
  FGlyph.Free;
  inherited Destroy;
end;

procedure TVrCustomThumb.SetGlyph(Value: TBitmap);
begin
  FGlyph.Assign(Value);
  AdjustBoundsRect;
end;

procedure TVrCustomThumb.SetThumbStates(Value: TVrThumbStates);
begin
  if FThumbStates <> Value then
  begin
    FThumbStates := Value;
    AdjustBoundsRect;
  end;
end;

procedure TVrCustomThumb.AdjustBoundsRect;
begin
  if not FGlyph.Empty then
    BoundsRect := Bounds(Left, Top, FGlyph.Width div ThumbStates, FGlyph.Height)
end;

procedure TVrCustomThumb.LoadFromResourceName(const ResName: string);
begin
  FGlyph.LoadFromResourceName(hInstance, ResName);
  AdjustBoundsRect;
end;

procedure TVrCustomThumb.Paint;
var
  Index, Offset: Integer;
begin
  ClearBitmapCanvas;
  Index := GetImageIndex;
  if Succ(Index) > ThumbStates then Index := 0;
  if (not FGlyph.Empty) then
  begin
    Offset := Index * Width;
    with BitmapCanvas do
    begin
      Brush.Style := bsClear;
      BrushCopy(ClientRect, FGlyph,
        Bounds(Offset, 0, FGlyph.Width div ThumbStates, FGlyph.Height), clOlive);
    end;
  end;
  inherited Paint;
end;

function TVrCustomThumb.GetImageIndex: Integer;
begin
  Result := 0;
end;

procedure TVrCustomThumb.SetDown(Value: Boolean);
begin
  if FDown <> Value then
  begin
    FDown := Value;
    UpdateControlCanvas;
  end;
end;

procedure TVrCustomThumb.CMMouseEnter(var Message: TMessage);
begin
  inherited;
  FHasMouse := True;
  UpdateControlCanvas;
end;

procedure TVrCustomThumb.CMMouseLeave(var Message: TMessage);
begin
  inherited;
  FHasMouse := false;
  UpdateControlCanvas;
end;}



end.