rm_dsgctrls.pas

这是一个功能强大

  Ini.Free;
end;

procedure RMRestoreToolWinPosition(aParentKey: string; f: TRMToolWin);
var
  Ini: TRegIniFile;
  lName: string;
  X, Y: integer;
  DN: string;
  NewDock: TRMDock;
  DNDocked: Boolean;
begin
  Ini := TRegIniFile.Create(RMRegRootKey + aParentKey);
  lName := rsForm + f.ClassName;

  f.Visible := False;
  X := Ini.ReadInteger(lName, rsX, f.Left);
  Y := Ini.ReadInteger(lName, rsY, f.Top);
  f.Width := Ini.ReadInteger(lName, rsWidth, f.Width);
  if f.Width < 40 then f.Width := 40;
  f.Height := Ini.ReadInteger(lName, rsHeight, f.Height);
  if f.Height < 40 then f.Height := 40;

  DNDocked := Ini.ReadBool(lName, rsDocked, TRUE);
  if DNDocked then
  begin
    DN := Ini.ReadString(lName, rsDockName, '');
    if f.Owner <> nil then
    begin
      NewDock := (f.Owner).FindComponent(DN) as TRMDock;
      if NewDock <> nil then
      begin
{$IFDEF USE_TB2K}
        f.CurrentDock := NewDock;
{$ELSE}
        f.DockedTo := NewDock;
{$ENDIF}
        f.DockPos := X;
        f.DockRow := Y;
      end;
    end;
  end
  else
  begin
{$IFDEF USE_TB2K}
    f.CurrentDock := nil;
{$ELSE}
    f.DockedTo := nil;
{$ENDIF}
{$IFDEF USE_TB2K}
    f.FloatingPosition := Point(X, Y);
    f.Floating := True;
    f.MoveOnScreen(True);
{$ELSE}
    f.Left := X;
    f.Top := Y;
{$ENDIF}
  end;
  f.Visible := Ini.ReadBool(lName, rsVisible, True);

  Ini.Free;
end;

const
  RulerAdj = 4 / 3;

function RMDirectoryExists(const aName: string): Boolean;
var
  Code: Integer;
begin
  Code := GetFileAttributes(PChar(aName));
  Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0);
end;

{$IFDEF COMPILER6_UP}
{$WARN SYMBOL_DEPRECATED OFF}
{$ENDIF}

function RMExcludeTrailingBackslash(const S: string): string;
begin
  Result := S;
  if IsPathDelimiter(Result, Length(Result)) then
    SetLength(Result, Length(Result) - 1);
end;

function RMForceDirectories(Dir: string): Boolean;
begin
  Result := True;
  if Length(Dir) = 0 then
  begin
    Result := False;
    Exit;
  end;
  Dir := RMExcludeTrailingBackslash(Dir);
  if (Length(Dir) < 3) or RMDirectoryExists(Dir)
    or (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem.
  Result := RMForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir);
end;

function RMSelectDirCB(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall;
begin
  if (uMsg = BFFM_INITIALIZED) and (lpData <> 0) then
    SendMessage(Wnd, BFFM_SETSELECTION, Integer(True), lpdata);
  result := 0;
end;

function RMSelectDirectory(const Caption: string; const Root: WideString;
  var Directory: string): Boolean;
var
  WindowList: Pointer;
  BrowseInfo: TBrowseInfo;
  Buffer: PChar;
  OldErrorMode: Cardinal;
  RootItemIDList, ItemIDList: PItemIDList;
  ShellMalloc: IMalloc;
  IDesktopFolder: IShellFolder;
  Eaten, Flags: ULONG {LongWord};
begin
  Result := False;
  if not RMDirectoryExists(Directory) then
    Directory := '';
  FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
  if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
  begin
    Buffer := ShellMalloc.Alloc(MAX_PATH);
    try
      RootItemIDList := nil;
      if Root <> '' then
      begin
        SHGetDesktopFolder(IDesktopFolder);
        IDesktopFolder.ParseDisplayName(Application.Handle, nil,
          POleStr(Root), Eaten, RootItemIDList, Flags);
      end;
      with BrowseInfo do
      begin
        hwndOwner := Application.Handle;
        pidlRoot := RootItemIDList;
        pszDisplayName := Buffer;
        lpszTitle := PChar(Caption);
        ulFlags := BIF_RETURNONLYFSDIRS;
        if Directory <> '' then
        begin
          lpfn := RMSelectDirCB;
          lParam := Integer(PChar(Directory));
        end;
      end;
      WindowList := DisableTaskWindows(0);
      OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
      try
        ItemIDList := ShBrowseForFolder(BrowseInfo);
      finally
        SetErrorMode(OldErrorMode);
        EnableTaskWindows(WindowList);
      end;
      Result := ItemIDList <> nil;
      if Result then
      begin
        ShGetPathFromIDList(ItemIDList, Buffer);
        ShellMalloc.Free(ItemIDList);
        Directory := Buffer;
      end;
    finally
      ShellMalloc.Free(Buffer);
    end;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMFontComboBox}

function GetFontMetrics(Font: TFont): TTextMetric;
var
  DC: HDC;
  SaveFont: HFont;
begin
  DC := GetDC(0);
  SaveFont := SelectObject(DC, Font.Handle);
  GetTextMetrics(DC, Result);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);
end;

function GetFontHeight(Font: TFont): Integer;
begin
  Result := GetFontMetrics(Font).tmHeight;
end;

{function GetItemHeight(Font: TFont): Integer;
var
  DC: HDC;
  SaveFont: HFont;
  Metrics: TTextMetric;
begin
  DC := GetDC(0);
  try
    SaveFont := SelectObject(DC, Font.Handle);
    GetTextMetrics(DC, Metrics);
    SelectObject(DC, SaveFont);
  finally
    ReleaseDC(0, DC);
  end;
  Result := Metrics.tmHeight + 2;
end;
}
const
  WRITABLE_FONTTYPE = 256;

function IsValidFont(Box: TRMFontComboBox; LogFont: TLogFont; FontType: Integer): Boolean;
begin
  Result := True;
  if (rmfoAnsiOnly in Box.Options) then
    Result := Result and (LogFont.lfCharSet = ANSI_CHARSET);
  if (rmfoTrueTypeOnly in Box.Options) then
    Result := Result and (FontType and TRUETYPE_FONTTYPE = TRUETYPE_FONTTYPE);
  if (rmfoFixedPitchOnly in Box.Options) then
    Result := Result and (LogFont.lfPitchAndFamily and FIXED_PITCH = FIXED_PITCH);
  if (rmfoOEMFontsOnly in Box.Options) then
    Result := Result and (LogFont.lfCharSet = OEM_CHARSET);
  if (rmfoNoOEMFonts in Box.Options) then
    Result := Result and (LogFont.lfCharSet <> OEM_CHARSET);
  if (rmfoNoSymbolFonts in Box.Options) then
    Result := Result and (LogFont.lfCharSet <> SYMBOL_CHARSET);
  if (rmfoScalableOnly in Box.Options) then
    Result := Result and (FontType and RASTER_FONTTYPE = 0);
end;

function EnumFontsProc(var EnumLogFont: TEnumLogFont; var TextMetric: TNewTextMetric;
  FontType: Integer; Data: LPARAM): Integer; export; stdcall;
var
  FaceName: string;
begin
  FaceName := StrPas(EnumLogFont.elfLogFont.lfFaceName);
  with TRMFontComboBox(Data) do
  begin
    if (Items.IndexOf(FaceName) < 0) and
      IsValidFont(TRMFontComboBox(Data), EnumLogFont.elfLogFont, FontType) then
    begin
      if EnumLogFont.elfLogFont.lfCharSet <> SYMBOL_CHARSET then
        FontType := FontType or WRITABLE_FONTTYPE;
      Items.AddObject(FaceName, TObject(FontType));
    end;
  end;
  Result := 1;
end;

constructor TRMFontComboBox.Create(AOwner: TComponent);
var
  liFont: TFont;
begin
  inherited Create(AOwner);
  FTrueTypeBMP := RMCreateBitmap('RM_TRUETYPE_FNT');
  FDeviceBMP := RMCreateBitmap('RM_DEVICE_FNT');
  FDevice := rmfdScreen;
  Style := csOwnerDrawVariable; //DropDownList;
  Sorted := True;
  DropDownCount := 18;
  Init;

  liFont := TFont.Create;
  try
    liFont.Name := 'Arial';
    liFont.Size := 16;
    FFontHeight := RMCanvasHeight('a', liFont);
  finally
    liFont.Free;
  end;
end;

destructor TRMFontComboBox.Destroy;
begin
  FTrueTypeBMP.Free;
  FDeviceBMP.Free;
  inherited Destroy;
end;

procedure TRMFontComboBox.CreateWnd;
var
  OldFont: TFontName;
begin
  OldFont := FontName;
  inherited CreateWnd;
  FUpdate := True;
  try
    PopulateList;
    inherited Text := '';
    SetFontName(OldFont);
    Perform(CB_SETDROPPEDWIDTH, 240, 0);
  finally
    FUpdate := False;
  end;
  if AnsiCompareText(FontName, OldFont) <> 0 then
    DoChange;
end;

procedure TRMFontComboBox.PopulateList;
var
  DC: HDC;
begin
  if not HandleAllocated then
    Exit;

  Items.BeginUpdate;
  try
    Clear;
    DC := GetDC(0);
    try
      if (FDevice = rmfdScreen) or (FDevice = rmfdBoth) then
        EnumFontFamilies(DC, nil, @EnumFontsProc, Longint(Self));
      if (FDevice = rmfdPrinter) or (FDevice = rmfdBoth) then
      begin
        try
          EnumFontFamilies(RMDesigner.Report.ReportPrinter.DC, nil, @EnumFontsProc, Longint(Self));
        except
        end;
      end;
    finally
      ReleaseDC(0, DC);
    end;
  finally
    Items.EndUpdate;
  end;
end;

procedure TRMFontComboBox.SetFontName(const NewFontName: TFontName);
var
  Item: Integer;
begin
  if FontName <> NewFontName then
  begin
    if not (csLoading in ComponentState) then
    begin
      HandleNeeded;
      for Item := 0 to Items.Count - 1 do
      begin
        if AnsiCompareText(Items[Item], NewFontName) = 0 then
        begin
          ItemIndex := Item;
          DoChange;
          Exit;
        end;
      end;
      if Style = csDropDownList then
        ItemIndex := -1
      else
        inherited Text := NewFontName;
    end
    else
      inherited Text := NewFontName;
    DoChange;
  end;
end;

function TRMFontComboBox.GetFontName: TFontName;
begin
  Result := inherited Text;
end;

function TRMFontComboBox.GetTrueTypeOnly: Boolean;
begin
  Result := rmfoTrueTypeOnly in FOptions;
end;

procedure TRMFontComboBox.SetOptions(Value: TFontListOptions);
begin
  if Value <> Options then
  begin
    FOptions := Value;
    Reset;
  end;
end;

procedure TRMFontComboBox.SetTrueTypeOnly(Value: Boolean);
begin
  if Value <> TrueTypeOnly then
  begin
    if Value then
      FOptions := FOptions + [rmfoTrueTypeOnly]
    else
      FOptions := FOptions - [rmfoTrueTypeOnly];
    Reset;
  end;
end;

procedure TRMFontComboBox.SetDevice(Value: TFontDevice);
begin
  if Value <> FDevice then
  begin
    FDevice := Value;
    Reset;
  end;
end;

procedure TRMFontComboBox.MeasureItem(Index: Integer; var Height: Integer);
begin
  if Index = -1 then
    Height := 15
  else
  begin
    Height := FFontHeight;
    //    Canvas.Font.Name := Items[index];
    //    Canvas.Font.Size := 16;
    //    Height := GetItemHeight(Canvas.Font);
  end;
end;

procedure TRMFontComboBox.DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState);
var
  Bitmap: TBitmap;
  BmpWidth: Integer;
  s: string;
  h: Integer;
begin
  with Canvas do
  begin
    FillRect(Rect);
    BmpWidth := 15;
    if (Integer(Items.Objects[Index]) and TRUETYPE_FONTTYPE) <> 0 then
      Bitmap := FTrueTypeBMP
    else if (Integer(Items.Objects[Index]) and DEVICE_FONTTYPE) <> 0 then
      Bitmap := FDeviceBMP
    else
      Bitmap := nil;
    if Bitmap <> nil then
    begin
      BmpWidth := Bitmap.Width;
      BrushCopy(Bounds(Rect.Left + 2, (Rect.Top + Rect.Bottom - Bitmap.Height)
        div 2, Bitmap.Width, Bitmap.Height), Bitmap, Bounds(0, 0, Bitmap.Width,
        Bitmap.Height), Bitmap.TransparentColor);
    end;

    if (not DroppedDown){$IFDEF COMPILER5_UP} or (odComboBoxEdit in State){$ENDIF} then
    begin
      Font.Assign(Font);
    end
    else
    begin
      Font.Name := Items[index];
      Font.Size := 16;
      if RMIsChineseGB then
      begin
        if ByteType(Font.Name, 1) = mbSingleByte then
          Font.CharSet := ANSI_CHARSET
        else
          Font.CharSet := GB2312_CHARSET;
      end;
    end;

    Rect.Left := Rect.Left + BmpWidth + 6;
    s := Items[index];
    h := TextHeight(s);
    TextOut(Rect.Left, Rect.Top + (Rect.Bottom - Rect.Top - h) div 2, s);
  end;
end;

procedure TRMFontComboBox.WMFontChange(var Message: TMessage);
begin
  inherited;
  Reset;
end;

procedure TRMFontComboBox.Change;
var
  I: Integer;
begin
  inherited Change;
  if Style <> csDropDownList then
  begin
    I := Items.IndexOf(inherited Text);
    if (I >= 0) and (I <> ItemIndex) then
    begin
      ItemIndex := I;
      DoChange;
    end;
  end;
end;

procedure TRMFontComboBox.Click;
begin
  inherited Click;
  DoChange;
end;

procedure TRMFontComboBox.DoChange;
begin
  if not (csReading in ComponentState) then
  begin
    if not FUpdate and Assigned(FOnChange) then
      FOnChange(Self);
  end;
end;

procedure TRMFontComboBox.Reset;
var
  SaveName: TFontName;
begin
  if HandleAllocated then
  begin
    FUpdate := True;
    try
      SaveName := FontName;
      PopulateList;
      FontName := SaveName;
    finally
      FUpdate := False;
      if FontName <> SaveName then
        DoChange;
    end;
  end;
end;

procedure TRMFontComboBox.CMFontChanged(var Message: TMessage);
begin
  inherited;
  Init;
end;

procedure TRMFontComboBox.CMFontChange(var Message: TMessage);
begin
  inherited;
  Reset;
end;

procedure TRMFontComboBox.Init;