cdibpanel.pas

Delphi控件

    begin
      CurrentControl := Controls[CurrentControlIndex];
      
      Assert(CurrentControlIndex < ControlCount);
      if not (CurrentControl is TWinControl) then
        if IntersectRect(D, FUpdateRect, CurrentControl.BoundsRect) then
        begin
          with CurrentControl do
            if (Visible or (csDesigning in ComponentState) and
              not (csNoDesignVisible in ControlStyle)) and
              RectVisible(DC, Rect(Left, Top, Left + Width, Top + Height)) then
            begin
              if csPaintCopy in Self.ControlState then
                ControlState := ControlState + [csPaintCopy];
              SaveIndex := SaveDC(DC);
              MoveWindowOrg(DC, Left, Top);
              IntersectClipRect(DC, 0, 0, Width, Height);

              if CurrentControl is TCustomDIBControl then
              begin
                FChildDIB.ReSize(Width, Height);
                FChildDIB.ResetHeader;
                THackDIBControl(CurrentControl).ControlDIB := FChildDIB;
              end;

              Perform(WM_PAINT, DC, 0);
              RestoreDC(DC, SaveIndex);
              ControlState := ControlState - [csPaintCopy];
            end;
        end;
    end;

    //Now do WinControls (last)
    if First <> nil then
    begin
      for FindControlIndex := ControlCount - 1 downto 0 do
        if Controls[FindControlIndex] = First then
        begin
          CurrentControlIndex := FindControlIndex;
          Break;
        end;
    end else
      CurrentControlIndex := 0;

    for CurrentControlIndex := CurrentControlIndex to ControlCount - 1 do
    begin
      CurrentControl := Controls[CurrentControlIndex];

      Assert(CurrentControlIndex < ControlCount);
      if (CurrentControl is TWinControl) then
        if IntersectRect(D, FUpdateRect, CurrentControl.BoundsRect) then
        begin
          with THackWinControl(CurrentControl) do
          begin
            if Ctl3D and (csFramed in ControlStyle) and
              (Visible or (csDesigning in ComponentState) and
              not (csNoDesignVisible in ControlStyle)) then
            begin
              FrameBrush := CreateSolidBrush(ColorToRGB(clBtnShadow));
              FrameRect(DC, Rect(Left - 1, Top - 1, Left + Width, Top + Height),
                FrameBrush);
              DeleteObject(FrameBrush);
              FrameBrush := CreateSolidBrush(ColorToRGB(clBtnHighlight));
              FrameRect(DC, Rect(Left, Top, Left + Width + 1, Top + Height + 1),
                FrameBrush);
              DeleteObject(FrameBrush);
            end;
          end;
        end;
    end;
  end;
end;

procedure TCustomDIBContainer.PaintHandler(var Message: TWMPaint);
var
  I, Clip, SaveIndex: Integer;
  DC: HDC;
begin
  DC := Message.DC;
  if ControlCount = 0 then
    PaintWindow(DC)
  else 
  begin
    SaveIndex := SaveDC(DC);
    Clip := SimpleRegion;
    for I := 0 to ControlCount - 1 do
      with TControl(Controls[I]) do
        if (Visible or (csDesigning in ComponentState) and
          not (csNoDesignVisible in ControlStyle)) and
          (csOpaque in ControlStyle) then
        begin
          Clip := ExcludeClipRect(DC, Left, Top, Left + Width, Top + Height);
          if Clip = NullRegion then Break;
        end;
    if Clip <> NullRegion then PaintWindow(DC);
    RestoreDC(DC, SaveIndex);
  end;
  PaintControls(DC, nil);
end;

procedure TCustomDIBContainer.SetBorderDrawPosition(const Value: TBorderDrawPosition);
begin
  FBorderDrawPosition := Value;
  Invalidate;
end;

procedure TCustomDIBContainer.SetBounds(aLeft, aTop, aWidth, aHeight: Integer);
begin
  inherited;
  if (FDIB <> nil) and not (csLoading in ComponentState) then
    FDIB.Resize(aWidth, aHeight);
end;

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

procedure TCustomDIBContainer.WMEraseBkGnd(var Message: TMessage);
begin
  Message.Result := 1;
end;

procedure TCustomDIBContainer.WMGetDlgCode(var Message: TMessage);
begin
  Message.Result := DLGC_WANTALLKEYS;
end;

procedure TCustomDIBContainer.WMPaint(var Message: TWMPaint);
var
  I: Integer;
  OrigDC, DC: HDC;
  PS: TPaintStruct;
  OldPal: HPalette;
  BlitType: TBlitType;
  CanSetDiBits: Boolean;
begin
  Message.Result := 0;
  if Message.DC = 0 then
    dc := beginpaint(handle, ps)
  else
    dc := Message.DC;
  try
    // painting to the control (the norm)
    if Message.DC = 0 then
      FUpdateRect := PS.rcPaint        // get the area we will be painting in
        // for painting to an alternate DC (non-owned canvas)
    else
    begin
      FAlteredRect := True;                    // stop height/width, etc checks
      GetClipBox(DC, FUpdateRect);    // get the area we will be painting in
    end;

    if not FAlteredRect then
    begin
      for I := 0 to ControlCount - 1 do
        if Controls[I] is TCustomDIBControl then
          THackDIBControl(Controls[I]).AlterUpdateRect(FUpdateRect);

      FUpdateRect.TopLeft := ClientToScreen(FUpdateRect.TopLeft);
      FUpdateRect.BottomRight := ClientToScreen(FUpdateRect.BottomRight);

      FUpdateRect.TopLeft := ScreenToClient(FUpdateRect.TopLeft);
      FUpdateRect.BottomRight := ScreenToClient(FUpdateRect.BottomRight);

      //For some reason, invalidating the whole form actually invalidates the height -2
      //so the next code is called endlessly.
      //Therefore I check if the difference in height is > 2
      if (FUpdateRect.Left <> PS.rcPaint.Left) or
        (FUpdateRect.Top <> PS.rcPaint.Top) or
        (FUpdateRect.Right <> PS.rcPaint.Right) or
        (abs(FUpdateRect.Bottom - PS.rcPaint.Bottom) > 2) then
      begin
        FAlteredRect := True;
        //Called in "Finally" block
        //        if Message.DC = 0 then
        //          EndPaint(handle, ps);
        ValidateRect(Handle, @PS.rcPaint);
        InvalidateRect(Handle, @FUpdateRect, False);
        Exit;
      end;
    end;
    FAlteredRect := False;

    FDIB.ClipRect := FUpdateRect;
    OrigDC := Message.DC;
    Message.DC := DIB.Handle;
    DoBeforePaint;
    PaintHandler(Message);
    DoAfterPaint;
    Message.DC := OrigDC;

    BlitType := btNormal;
    if not (csDesigning in ComponentState) then
      if GetDeviceCaps(DC, BITSPixel) = 8 then
      begin
        CanSetDiBits := (GetDeviceCaps(DC, RasterCaps) and RC_DIBToDEV) <> 0;
        if (FPalette <> nil) and (FPalette.UseTable) and (CanSetDiBits) then
          BlitType := btLookUp
        else
          BlitType := btNeedPalette
      end;

    case BlitType of
      btNormal:
        with FUpdateRect do
          BitBlt(DC, Left, Top, Right - Left, Bottom - Top, dib.handle, Left, Top, SrcCopy);

      btNeedPalette:
        begin
          if Assigned(FPalette) then  //Dave Parkinson
            OldPal := SelectPalette(DC, FPalette.palette, False)
          else
            OldPal := 0;
          with FUpdateRect do
            BitBlt(DC, Left, Top, Right - Left, Bottom - Top, dib.handle,
              Left, Top, SrcCopy);
          if OldPal <> 0 then
            SelectPalette(DC, OldPal, True);
        end;

      btLookup:
        begin
          OldPal := SelectPalette(DC, FPalette.palette, False);
          with FUpdateRect do
            dib.Render8Bit(DC, Left, Top, Right - Left, Bottom - Top,
              Left, Top, SrcCopy, FPalette);
          SelectPalette(DC, OldPal, True);
        end;
    end;
  finally
    if Message.DC = 0 then EndPaint(Handle, PS);
  end;
end;


procedure TCustomDIBContainer.WndProc(var Message: TMessage);
var
  CControl: TControl;
  ParentRect, CRect: TRect;
  CPos: TPoint;
  ParentControl: TWinControl;
begin
  if Message.Msg = WM_LButtonUp then
  begin
    CControl := GetCaptureControl;
    if (CControl <> nil) then 
    begin
      Windows.GetCursorPos(CPos);
      CRect.TopLeft := CControl.ClientToScreen(Point(CControl.Left, CControl.Top));
      CRect.BottomRight := Point(CRect.Left + CControl.Width, CRect.Top + CControl.Height);
      ParentRect := CRect;
      if not PtInRect(CRect, CPos) then 
      begin
        if THackControl(CControl).MouseCapture then
          if CControl <> Self then CControl.Perform(CM_MouseLeave, 0, 0);

        ParentControl := FindVCLWindow(CPos);
        if ParentControl <> nil then 
        begin
          CRect.TopLeft := ParentControl.ScreenToClient(CPos);
          CControl := ParentControl.ControlAtPos(CRect.TopLeft, False);
          if CControl <> nil then CControl.Perform(CM_MouseEnter, 0, 0);
        end;
      end;
    end;
  end;

(*
  if FActiveControl is TCustomDIBControl then begin
    if not FindDIBChildMessage(Message.Msg) then
      inherited
    else begin
      FActiveControl.WindowProc(Message);
      if Message.Result <> 0 then
        inherited;
    end;
  end else
    inherited;
*)
  inherited;
end;

procedure TCustomDIBContainer.AdjustClientRect(var Rect: TRect);
begin
  inherited;
  if FDIBBorder <> nil then
    with DIBBorder do
    begin
      Inc(Rect.Top, BorderTop.Size);
      Dec(Rect.Bottom, BorderBottom.Size);
      Inc(Rect.Left, BorderLeft.Size);
      Dec(Rect.Right, BorderRight.Size);
    end;
end;

procedure TCustomDIBContainer.WMSetCursor(var Message: TMessage);
var
  Control: TControl;
  CursorPos: TPoint;
begin
  if csDesigning in ComponentState then
    inherited
  else 
  begin
    GetCursorPos(CursorPos);
    CursorPos := ScreenToClient(CursorPos);
    Control := ControlAtPos(CursorPos, False);
    if not (Assigned(Control)) or (Control.Perform(WM_SETCURSOR,
      Message.WParam, Message.LParam) <> 1) then
      inherited;
  end;
end;

{ TCustomDIBImageContainer }

constructor TCustomDIBImageContainer.Create(AOwner: TComponent);
begin
  inherited;
  FIndexImage := TDIBImageLink.Create(Self);
  FIndexImage.OnImageChanged := DoImageChanged;
end;

destructor TCustomDIBImageContainer.Destroy;
begin
  FIndexImage.Free;
  inherited;
end;

procedure TCustomDIBImageContainer.Paint;
var
  X, Y: Integer;
  R: TRect;
  TheDIB: TMemoryDIB;
begin
  if not FIndexImage.GetImage(TheDIB) then 
  begin
    inherited;
    exit;
  end;

  if TileMethod <> tmTile then
    if (TheDIB.Width <> Width) or (TheDIB.Height <> Height) then
      inherited;

  if TheDIB.Height > 0 then 
  begin
    case TileMethod of
      tmCenter:
        begin
          TheDIB.Draw(Width div 2 - (TheDIB.Width div 2),
            Height div 2 - (TheDIB.Height div 2),
            TheDIB.Width, TheDIB.Height, FDIB, 0, 0);
        end;
      tmTile:
        begin
          Y := FDIB.ClipRect.Top;
          if Y mod TheDIB.Height <> 0 then
            Y := Y - Y mod TheDIB.Height;
          while Y < FDIB.ClipRect.Bottom do
          begin
            X := FDIB.ClipRect.Left;
            if X mod TheDIB.Width <> 0 then
              X := X - X mod TheDIB.Width;
            while X < FDIB.ClipRect.Right do 
            begin
              if IntersectRect(R, FUpdateRect,
                Rect(X, Y, X + TheDIB.Width, Y + TheDIB.Height)) then
                TheDIB.Draw(X, Y, TheDIB.Width, TheDIB.Height, FDIB, 0, 0);
              Inc(X, TheDIB.Width);
            end;
            Inc(Y, TheDIB.Height);
          end;
        end;
    end;
  end;
end;

procedure TCustomDIBImageContainer.SetTileMethod(const Value: TTileMethod);
begin
  FTileMethod := Value;
  invalidate;
end;

procedure TCustomDIBImageContainer.WndProc(var Message: TMessage);
begin
  if (csDestroying in ComponentState) or
    (TileMethod <> tmTile) or
    (Message.msg <> WM_EraseBkGnd) then
    inherited;
end;

procedure TCustomDIBImageContainer.ImageChanged(ID: Integer; Operation: TDIBOperation);
begin
  case Operation of
    doRemove:
      if ID = IndexImage.DIBIndex then
        IndexImage.DIBIndex := -1
      else
        if ID < IndexImage.DIBIndex then
          IndexImage.DIBIndex := IndexImage.DIBIndex - 1;
      doChange: if ID = IndexImage.DIBIndex then Invalidate;
  end;
end;

function TCustomDIBImageContainer.GetDIBImageList: TCustomDIBImageList;
begin
  Result := FIndexImage.DIBImageList;
end;

procedure TCustomDIBImageContainer.SetDIBImageList(const Value: TCustomDIBImageList);
begin
  FIndexImage.DIBImageList := Value;
end;

procedure TCustomDIBImageContainer.DoImageChanged(Sender: TObject;
  ID: Integer; Operation: TDIBOperation);
begin
  ImageChanged(ID, Operation);
end;

end.