explbtn.pas

地址档案管理系统

  popupPushed := False;
  MouseIn := False;
  backBitmapCreated := False;
  pushed := False;
  painted := False;
  initialized := False;
  updatingSize := False;
  fakeResize := False;
  Alignment := taCenter;
  Width := 50;
  Height := 40;
  wasObscured := False;
  regenerating := False;

  if (csDesigning in ComponentState) and not (csLoading in TControl(Owner).ComponentState) then
    Caption := 'ExplorerButton';

  FAllowAllUp := False;
  FBevelStyle := bsRaised;
  FDown := False;
  FDropDown := nil;
  FDropDownStyle := ddsIExplorer;
  FEnabled := True;
  FExplorerPopup := nil;
  FGroupIndex := 0;
  FLayout := blBitmapTop;
  FOptions := [boPopupMark, boShowBevel, boShowDownPattern];
  FShadingType := stMedium;
  FUnselectedFontColor := clWindowText;

  FButtonSize := bsCustom;
  FSmallWidth := 23;
  FSmallHeight := 22;
  FLargeWidth := 39;
  FLargeHeight := 38;

  TabStop := True;
end;

destructor TExplorerButton.Destroy;
begin
  FBitmap.Free;
  FNoFocusBitmap.Free;
  FDisabledBitmap.Free;
  IBitmap.Free;
  backBitmap.Free;
  if pattern <> nil then
  begin
    pattern.Free;
    pattern := nil;
  end;
  inherited Destroy;
end;

procedure TExplorerButton.BitmapChange(Sender: TObject);
begin
  if not FBitmap.Empty and FNoFocusBitmap.Empty and (csDesigning in ComponentState) then
    CreateGrayscaleBitmap(IBitmap, FBitmap);

  if not FBitmap.Empty then
    FBitmap.Dormant;
  Repaint;
end;

procedure TExplorerButton.NoFocusBitmapChange(Sender: TObject);
begin
  if not FBitmap.Empty and FNoFocusBitmap.Empty and (csDesigning in ComponentState) then
  begin
    CreateGrayscaleBitmap(IBitmap, FBitmap);
  end;

  if not FNoFocusBitmap.Empty then
   begin
     IBitmap.Free;
      IBitmap := TBitmap.Create;
    FNoFocusBitmap.Dormant;
   end;
  Repaint;
end;

procedure TExplorerButton.CreateParams(var Params: TCreateParams);
begin
     inherited CreateParams(Params);
     if (boTransparent in FOptions) and not (csDesigning in ComponentState) then
       Params.ExStyle := Params.ExStyle + WS_EX_TRANSPARENT;
     painted := False;
end;

procedure TExplorerButton.DefineProperties(Filer: TFiler);
begin
  Filer.DefineBinaryProperty('IBitmap', ReadIBitmap, WriteIBitmap, True);
end;

procedure TExplorerButton.ReadIBitmap(Stream: TStream);
begin
  IBitmap.LoadFromStream(Stream);
end;

procedure TExplorerButton.WriteIBitmap(Stream: TStream);
begin
  if not IBitmap.Empty then
    IBitmap.SaveToStream(Stream)
end;

procedure TExplorerButton.DisabledBitmapChange(Sender: TObject);
begin
  if not FDisabledBitmap.Empty then
    FDisabledBitmap.Dormant;
  if not FEnabled then
    Repaint;
end;

procedure TExplorerButton.CreateWnd;
begin
  inherited CreateWnd;
  FActive := FDefault;
end;

procedure TExplorerButton.SetButtonStyle(ADefault: Boolean);
const
  BS_MASK = $000F;
var
  Style: Word;
begin
  if HandleAllocated then
  begin
    if ADefault then Style := BS_DEFPUSHBUTTON else Style := BS_PUSHBUTTON;
    if GetWindowLong(Handle, GWL_STYLE) and BS_MASK <> Style then
      SendMessage(Handle, BM_SETSTYLE, Style, 1);
  end;
end;

procedure TExplorerButton.SetDefault(Value: Boolean);
begin
  FDefault := Value;
  if HandleAllocated then
    with GetParentForm(Self) do
      Perform(CM_FOCUSCHANGED, 0, Longint(ActiveControl));
end;

procedure TExplorerButton.CMDialogKey(var Message: TCMDialogKey);
begin
  with Message do
    if  (((CharCode = VK_RETURN) and FActive) or
      ((CharCode = VK_ESCAPE) and FCancel)) and
      (KeyDataToShiftState(Message.KeyData) = []) and CanFocus then
    begin
      Click;
      Result := 1;
    end else
      inherited;
end;

procedure TExplorerButton.CMFocusChanged(var Message: TCMFocusChanged);
begin
  with Message do
    if Sender is TExplorerButton then
      FActive := Sender = Self
    else
      FActive := FDefault;
  SetButtonStyle(FActive);
  inherited;
end;

procedure TExplorerButton.CMDialogChar(var Message: TCMDialogChar);
var lpPoint : TPoint;
begin
  with Message do
    if IsAccel(CharCode, Caption)and Enabled and Visible then
  begin
    MouseIn := True;
    Pushed := False;
    Repaint;
    Application.ProcessMessages;
    WMLButtonDown( TWMLBUTTONDOWN(Message));
    Application.ProcessMessages;
    WMLButtonUp( TWMLBUTTONUP(Message));
    Application.ProcessMessages;
    GetCursorPos(lpPoint);
    lpPoint := GetParentForm(self).ScreenToClient(lpPoint);
    if not  ((lpPoint.y > top) and (lpPoint.y < top + height)
      and (lpPoint.x > left) and (lpPoint.x < left + width)) then
    begin
      MouseIn := False;
      Repaint;
    end;
    Result := 1;
  end;
end;

procedure TExplorerButton.ComputeExtent(TempCaption: PChar; var TempRect: TRect; theCanvas: TCanvas);
var Flags: Integer;
begin
  if Alignment = taLeftJustify then
    Flags := DT_LEFT
  else if Alignment = taCenter then
    Flags := DT_CENTER
  else Flags := DT_RIGHT;

  if boWordWrap in FOptions then
  begin
    Flags := Flags or DT_WORDBREAK;
    (* Sometimes DrawText looses the last word, except when there's a space character. Uh ? *)
    StrCat(TempCaption, ' ');
  end;

  DrawText(theCanvas.handle, TempCaption, StrLen(TempCaption), TempRect, DT_CALCRECT or Flags);
end;

(*
 * These thresholds are used for the grayscaling and were experimentaly
 * determined
 *)
const THRESHOLD1_LIGHT = 205;
      THRESHOLD2_LIGHT = 127;
      THRESHOLD3_LIGHT = 68;
      THRESHOLD1_MEDIUM = 553;
      THRESHOLD2_MEDIUM = 231;
      THRESHOLD3_MEDIUM = 57;
      THRESHOLD1_DARK = 335;
      THRESHOLD2_DARK = 274;
      THRESHOLD3_DARK = 175;

procedure TExplorerButton.CreateGrayscaleBitmap(outputbmp, bmp: TBitmap);
var x, y: Integer;
    TransparentColor, col: LongInt;
    r, g, b, sum, threshold1, threshold2, threshold3: SmallInt;
begin
  outputbmp.Assign(bmp);
  TransparentColor := ColorToRGB(bmp.Canvas.Pixels[0,0]);
  if FShadingType = stLight then
  begin
    threshold1 := THRESHOLD1_LIGHT;
    threshold2 := THRESHOLD2_LIGHT;
    threshold3 := THRESHOLD3_LIGHT;
  end
  else
  if FShadingType = stMedium then
  begin
    threshold1 := THRESHOLD1_MEDIUM;
    threshold2 := THRESHOLD2_MEDIUM;
    threshold3 := THRESHOLD3_MEDIUM;
  end
  else
  begin
    threshold1 := THRESHOLD1_DARK;
    threshold2 := THRESHOLD2_DARK;
    threshold3 := THRESHOLD3_DARK;
  end;
  for x := 0 to bmp.Width do
    for y := 0 to bmp.Height do
    begin
      col := ColorToRGB(bmp.Canvas.Pixels[x, y]);
      if col <> TransparentColor then
      begin
        r := col shr 16;
        g := (col shr 8) and $00FF;
        b := col and $0000FF;
        sum := r + g + b;
        if sum > THRESHOLD1 then
          outputbmp.Canvas.Pixels[x, y] := clWhite
        else if sum > THRESHOLD2 then
          outputbmp.Canvas.Pixels[x, y] := clBtnHighlight
        else if sum > THRESHOLD3 then
          outputbmp.Canvas.Pixels[x, y] := clBtnShadow
        else
          outputbmp.Canvas.Pixels[x, y] := clBlack;
      end;
   end;
   if not bmp.Empty then
     bmp.Dormant;
   {$IFNDEF WIN32}
   if not outputbmp.Empty then
     outputbmp.Dormant;
   {$ENDIF}
end;

procedure TExplorerButton.DrawTheText(theCanvas: TCanvas; TempRect: TRect; TempCaption: PChar);
var Flags: Integer;
begin
  if Alignment = taLeftJustify then
    Flags := DT_LEFT
  else if Alignment = taCenter then
    Flags := DT_CENTER
  else Flags := DT_RIGHT;

  if boWordWrap in FOptions then
           Flags := Flags or DT_WORDBREAK;

  if bool_Version95 then
  begin
    {$IFDEF WIN32}
    DrawTextEx(theCanvas.handle, TempCaption, StrLen(TempCaption), TempRect,
            DT_END_ELLIPSIS or Flags, nil);
    {$ELSE}
    DrawText(theCanvas.handle, TempCaption, StrLen(TempCaption), TempRect, Flags);
    {$ENDIF}
  end
  else
    (* NT 3.51 users *)
    DrawText(theCanvas.handle, TempCaption, StrLen(TempCaption), TempRect, Flags);
end;

(*
 * Drawing of a disabled text (Win95 style)
 *)
procedure TExplorerButton.DrawDisabledText(theCanvas: TCanvas; TempRect: TRect; TempCaption: PChar);
begin
  theCanvas.Brush.Style := bsClear;
  theCanvas.Font.Color := clBtnHighlight;
  with TempRect do
  begin
    left := left + 1;
    top  := top + 1;
    right:= right + 1;
    bottom:= bottom + 1;
  end;
  DrawTheText(theCanvas, TempRect, TempCaption);
  theCanvas.Font.Color := clBtnShadow;
  with TempRect do
  begin
    left := left - 1;
    top  := top - 1;
    right:= right - 1;
    bottom:= bottom - 1;
  end;
  DrawTheText(theCanvas, TempRect, TempCaption);
end;

procedure TExplorerButton.DrawOutline(theCanvas: TCanvas; pushed: Boolean);
var
  buttonWidth: Integer;
begin
  if boShowBevel in FOptions then
  begin
    buttonWidth := Width;
    if  FDropDownStyle = ddsOffice then
      Dec(buttonWidth, 11);

     if BevelStyle = bsRaised then
     begin
       if (pushed) then
         theCanvas.Pen.Color := clBtnShadow
        else
         theCanvas.Pen.Color := clBtnHighlight;
     end
     else
     begin
       if (pushed) then
         theCanvas.Pen.Color := clBtnHighlight
        else
         theCanvas.Pen.Color := clBtnShadow;
     end;

    theCanvas.MoveTo(0, Height-1);
    theCanvas.LineTo(0, 0);
    theCanvas.LineTo(buttonWidth-1, 0);

     if BevelStyle = bsRaised then
     begin
       if (pushed) then
         theCanvas.Pen.Color := clBtnHighlight
        else
         theCanvas.Pen.Color := clBtnShadow;
     end
     else
     begin
       if (pushed) then
         theCanvas.Pen.Color := clBtnShadow
        else
         theCanvas.Pen.Color := clBtnHighlight;
     end;

    theCanvas.LineTo(buttonWidth-1, Height-1);
    theCanvas.LineTo(0, Height-1);

    if FDropDownStyle = ddsOffice then
     begin
       if ((popupPushed or popupOpened) and (BevelStyle = bsLowered)) or (((not popupPushed)
            and (not popupOpened)) and (BevelStyle = bsRaised)) then
         theCanvas.Pen.Color := clBtnHighLight
       else
         theCanvas.Pen.Color := clBtnShadow;

      theCanvas.MoveTo(buttonWidth, Height-1);
      theCanvas.LineTo(buttonWidth, 0);
      theCanvas.LineTo(Width-1, 0);

       if ((popupPushed or popupOpened)  and (BevelStyle = bsLowered))
           or (((not popupPushed) and (not popupOpened)) and (BevelStyle = bsRaised)) then
         theCanvas.Pen.Color := clBtnShadow
       else
         theCanvas.Pen.Color := clBtnHighLight;

      theCanvas.LineTo(Width-1, Height-1);
      theCanvas.LineTo(buttonWidth-1, Height-1);
     end
  end;
end;

procedure TExplorerButton.DrawPopupMark(theCanvas: TCanvas; x, y: Integer);
var theColor: TColor;
begin
  theColor := theCanvas.Font.Color;
  if FDropDownStyle = ddsIExplorer then
  begin
     theCanvas.Pixels[x    , y - 1] := theColor;
     theCanvas.Pixels[x + 1, y - 1] := theColor;
     theCanvas.Pixels[x + 2, y - 1] := theColor;
     theCanvas.Pixels[x + 3, y - 1] := theColor;
     theCanvas.Pixels[x + 4, y - 1] := theColor;
     theCanvas.Pixels[x + 5, y - 1] := theColor;
     theCanvas.Pixels[x + 6, y - 1] := theColor;
  end;

  theCanvas.Pixels[x + 1, y    ] := theColor;
  theCanvas.Pixels[x + 2, y    ] := theColor;
  theCanvas.Pixels[x + 3, y    ] := theColor;
  theCanvas.Pixels[x + 4, y    ] := theColor;
  theCanvas.Pixels[x + 5, y    ] := theColor;

  theCanvas.Pixels[x + 2, y + 1] := theColor;
  theCanvas.Pixels[x + 3, y + 1] := theColor;
  theCanvas.Pixels[x + 4, y + 1] := theColor;

  theCanvas.Pixels[x + 3, y + 2] := theColor;
end;

procedure TExplorerButton.GetLost;
begin
  if FGroupIndex = 0 then
    FDown := False;
  Pushed := False;
  MouseIn := False;
  Repaint;
end;