На главную Наши проекты:
Журнал   ·   Discuz!ML   ·   Wiki   ·   DRKB   ·   Помощь проекту
ПРАВИЛА FAQ Помощь Участники Календарь Избранное RSS
msm.ru
Модераторы: jack128, Rouse_, Krid
  
    > ShowMessage - нельзя ли цветным сделать? , ... или что-то другое есть подобное?
      Цветным? Синий ShowMessage, красный ShowMessage, зеленый ShowMessage? ;)

      Ну а вообще, почему бы и нет?

      ExpandedWrap disabled
        unit Unit2;
         
        interface
         
        uses
          Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
          Dialogs, StdCtrls;
         
        type
          TForm2 = class(TForm)
            Button1: TButton;
            procedure Button1Click(Sender: TObject);
          private
            procedure WMUser(var Message: TMessage); message WM_USER;
          end;
         
        var
          Form2: TForm2;
         
        implementation
         
        {$R *.dfm}
         
        procedure TForm2.Button1Click(Sender: TObject);
        begin
          PostMessage(Handle, WM_USER, 0, 0);
          MessageBox(Handle, 'This Is A colored Message Box', 'Colored MessageBox.',
            MB_OK or MB_ICONWARNING);
        end;
         
        function NewOpenWndProc(Wnd: HWND; uMsg: DWORD;
          WParam, LParam:integer): Integer; stdcall;
        begin
          case uMsg of
            WM_CTLCOLORSTATIC:
            begin
              Result := CallWindowProc(Pointer(GetWindowLong(Wnd, GWL_USERDATA)),
                Wnd, uMsg, WParam, LParam);
              SetTextColor(WParam, $FF0000);
              Exit;
            end;
            WM_COMMAND:
            begin
              EndDialog(Wnd, 0);
              Exit;
            end;
            WM_NCDESTROY:
              Result := 1;
          else
            Result := CallWindowProc(Pointer(GetWindowLong(Wnd, GWL_USERDATA)),
              Wnd, uMsg, WParam, LParam);
          end;
        end;
         
        procedure TForm2.WMUser(var Message: TMessage);
        var
          hMBHandle: HWND;
        begin
          hMBHandle := GetActiveWindow;
          if hMBHandle <> 0 then
            SetWindowLong(hMBHandle, GWL_USERDATA,
              SetWindowLong(hMBHandle, DWL_DLGPROC, DWORD(@NewOpenWndProc)));
        end;
         
        end.


      Это сообщение было перенесено сюда или объединено из темы "ShowMessage - нельзя ли цветным сделать?"
        Вот такие варианты можно использовать:
        1) Стандартный ShowMessage (описан в Dialogs.pas) использует CreateMessageDialog(...): TForm для
        получения диалога. Так что можно самостоятельно его получить и выполнить "раскраску" его элементов
        самостоятельно. На нем располагаются:
        а) для отображения текста: компонент TLabel с именем "Message";
        б) для иконки: компонент TImage с именем "Image";
        в) кнопки TButton в зависимости от опций с именами "Yes", "No", "OK", "Cancel", "Abort", "Retry",
        "Ignore", "All", "NoToAll", "YesToAll", "Help".
        Так что можно использовать конструкции вида:
        ExpandedWrap disabled
          ...
           
          uses ..., Dialogs;
           
          ...
          function MyShowMessage( const Msg: string; DlgType: TMsgDlgType = mtInformation; Buttons: TMsgDlgButtons = [mbOK]; HelpCtx: Longint = 0; X: integer = -1; Y: Integer= -1; const HelpFileName: string = '' ) : Integer;
          var
             AComp: TComponent;
             ADlgForm : TForm;
          begin
             ADlgForm := CreateMessageDialog(Msg, DlgType, Buttons);
           
             with ADlgForm do
             try
                // Раскрашиваем что надо...
                   // получить нужный компонент на форме
                   AComp := ADlgForm.FindComponent( 'Message' ); // здесь пытаемся получить TLabel для сообщения (имя должно быть "Message")
                   if AComp is TLabel then
                      TLabel(AComp).Color := clRed; // меняем цвет на красный
           
                    ... аналогично можно изменять и остальное ...
                    ... можно и добавить новое ...
           
                // Далее стандартно (как в Dialogs.pas:: MessageDlgPosHelp)
                HelpContext := HelpCtx;
                HelpFile := HelpFileName;
                if X >= 0 then Left := X; if Y >= 0 then Top := Y;
                if (Y < 0) and (X < 0) then Position := poScreenCenter;
           
                Result := ShowModal;
           
             finally
                Free;
             end;
          end;



        2) создать свою форму для сообщений и использовать дизайнер Delphi, имея полную свободу действий.
          Вариант с перехватом форм ShowMessage\MessageDlg по Screen.OnActiveFormChange
          ExpandedWrap disabled
            type
              TForm1 = class(TForm)
                Button1: TButton;
                procedure Button1Click(Sender: TObject);
              private
                { Private declarations }
              public
                { Public declarations }
                procedure DoCustomizeMessageForm(Sender:TObject);
                procedure CustomizeMessageFont(_Color,_dSize:integer;_Style:TFontStyles;const _Name:string);
              end;
             
            var
              Form1: TForm1;
             
            implementation
             
            {$R *.dfm}
            type
              TMsgFontParams = record
                Color:integer;
                Style:TFontStyles;
                dSize:integer;
                Name:String;
                _SaveProc:TNotifyEvent;
              end;
            var
              MsgFontParams:TMsgFontParams;
            procedure TForm1.CustomizeMessageFont(_Color,_dSize:integer;_Style:TFontStyles;const _Name:string);
            begin
              with MsgFontParams do
              begin
                _SaveProc:=Screen.OnActiveFormChange;
                Color:=_Color;
                dSize:=_dSize;
                Style:=_Style;
                Name:=_Name;
              end;
              Screen.OnActiveFormChange:=DoCustomizeMessageForm;
            end;
             
            procedure TForm1.DoCustomizeMessageForm(Sender:TObject);
            var
              F:TForm;L:TLabel; i,dH:integer;
            begin
              try
                F:=Screen.ActiveForm;
                if (F <> Nil) and F.ClassNameIs('TMessageForm') then
                begin
                  dH:=0;
                  for i:=0 to F.ControlCount-1 do
                    if F.Controls[i] is TLabel then
                    begin
                      L:=TLabel(F.Controls[i]);
                      dH:=L.Height;
                      with L.Font do
                      begin
                        Color:=MsgFontParams.Color;
                        Style:=MsgFontParams.Style;
                        Size:=Size+MsgFontParams.dSize;
                        if MsgFontParams.Name <> '' then
                          Name:=MsgFontParams.Name;
                        dH:=L.Height-dH;
                        if dH <= 0 then Break;
                      end;
                    end
                    else
                    //смещаем кнопки при изменении высоты TLabel
                    //(!!! в Controls кнопки идут после TLabel)
                    if (dH > 0) and (F.Controls[i] is TButton) then
                      with F.Controls[i] do Top:=Top+dH;
                  if dH > 0 then
                    F.Height:=F.Height+dH;
                end;
                if Assigned(MsgFontParams._SaveProc) then
                  MsgFontParams._SaveProc(Sender);
              finally
                //!!! воcстанавливаем прежний обработчик или Nil
                Screen.OnActiveFormChange:=MsgFontParams._SaveProc;
              end;
            end;
             
            procedure TForm1.Button1Click(Sender: TObject);
            begin
              CustomizeMessageFont(clRed,0,[],'');
              MessageDlg('Hello, World!',mtInformation,[mbYes,mbNo],0);
              CustomizeMessageFont(clBlue,4,[fsBold,fsItalic],'Times New Roman');
              ShowMessage('Hello, World!');
              //стандартный стиль
              ShowMessage('Hello, World!');
            end;
          Сообщение отредактировано: leo -
          0 пользователей читают эту тему (0 гостей и 0 скрытых пользователей)
          0 пользователей:


          Рейтинг@Mail.ru
          [ Script execution time: 0,0223 ]   [ 17 queries used ]   [ Generated: 28.03.24, 16:22 GMT ]