Einzelnen Beitrag anzeigen

Benutzerbild von KodeZwerg
KodeZwerg

Registriert seit: 1. Feb 2018
3.685 Beiträge
 
Delphi 11 Alexandria
 
#9

AW: TBitmap in Konsolen Anwendung

  Alt 9. Jun 2018, 20:40
Ich weiß nicht in wie fern das umsetzbar ist, unter Windows mit der Winapi kann man sich auch selbst eine bitmap-ähnliche Funktionsweise zusammen Schustern ohne auf die Graphics Unit zurückgreifen zu müssen, Moderator Luckie hat da echt guten Code auf Lager.
Hier ein Beispiel was ich so gefunden habe, aber wie gesagt, ob ein Linux oder ein Mac solche Api Funktionen anbietet ist mir fremd, da musst Du selbst mal suchen wie eine Mögliche Portierung aussehen könnte!
Delphi-Quellcode:
{******************************************************************************}
{                                                                              }
{                           Demo Bitmap-Menü                                   }
{                                                                              }
{                    Copyright (c) 2001 Michael Puff                           }
{                           www.luckie-online.de                               }
{                          mpuff@luckie-online.de                              }
{                                                                              }
{******************************************************************************}
program bitmapmenu;

{$R resource.res}

uses
  Windows,
  Messages;

const
  ClassName = 'WndClass';
  AppName = 'Bitmap-Menü-Demo';
  WindowWidth = 500;
  WindowHeight = 350;

  IDM_KUCKUCK = 1;
  IDM_LERCHE = 2;
  IDM_SPATZ = 3;

var
  hMenu, hPopupMenu: Cardinal;

{ GetLastError }
function DisplayErrorMsg(hWnd: THandle): DWORD;
var
  szBuffer: array[0..255] of Char;
begin
  FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, GetLastError, 0, szBuffer,
    sizeof(szBuffer), nil);
  MessageBox(hWnd, szBuffer, 'Fehler', MB_ICONSTOP);
  result := GetLastError;
end;

procedure MenuBmp(idBmpStart: DWORD; dc: HDC; cntItems, ItemHeight: Byte; hWnd: Cardinal);
var
  i: Integer;
  hBmp: HBITMAP;
  bmp: Windows.BITMAP;
  hdcBmp: HDC;
begin
  for i := 0 to cntItems-1 do
  begin
    hBmp := LoadBitmap(hInstance, MAKEINTRESOURCE(idBmpStart+i));
    GetObject(hBmp, sizeof(BITMAP), @bmp);
    hdcBmp := CreateCompatibleDC(dc);
    SelectObject(hdcBmp, hBmp);
    StretchBlt(dc, 2, ItemHeight*i+2, 15, 15, hdcBmp, 0, 0, bmp.bmWidth, bmp.bmHeight, SRCCOPY);
  end;
  ReleaseDC(hWnd, hdcBmp);
  DeleteObject(hBmp);
end;

function WndProc(hWnd: HWND; uMsg: UINT; wParam: wParam; lParam: LParam):
  lresult; stdcall;
var
  mi : PMEASUREITEMSTRUCT;
  di : PDRAWITEMSTRUCT;
begin
  Result := 0;
  case uMsg of
    WM_CREATE:
    begin
      hMenu := CreateMenu;
      hPopupMenu := CreateMenu;
      AppendMenu(hPopupMenu, MF_OWNERDRAW, IDM_KUCKUCK, '&Kuckuck');
      AppendMenu(hPopupMenu, MF_OWNERDRAW, IDM_LERCHE, '&Lerche');
      AppendMenu(hPopupMenu, MF_OWNERDRAW, IDM_SPATZ, '&Spatz');
      AppendMenu(hMenu, MF_POPUP, hPopupMenu, '&Datei');
      SetMenu(hWnd, hMenu);
    end;
    WM_MEASUREITEM:
    begin
      mi := PMEASUREITEMSTRUCT(lParam);
      case mi.CtlType of
        ODT_MENU:
        begin
          mi.itemWidth := 100;
          mi.itemHeight := 19;
        end
      end;
    end;
    WM_DRAWITEM:
    begin
      di := PDRAWITEMSTRUCT(lParam);
      case di.CtlType of
        ODT_MENU:
        begin
          if (di.itemState and ODS_SELECTED = ODS_SELECTED) then
          begin
            FillRect(di.hDC, di.rcItem, GetSysColorBrush(COLOR_HIGHLIGHT));
            SetTextColor(di.hDC, GetSysColor(COLOR_HIGHLIGHTTEXT));
          end
          else
          begin
            FillRect(di.hDC, di.rcItem, GetSysColorBrush(COLOR_BTNFACE));
            SetTextColor(di.hDC, GetSysColor(COLOR_WINDOWTEXT));
          end;
          SetBkMode(di.hDC, TRANSPARENT);
          di.rcItem.Left := di.rcItem.left + 30;
          DrawText(di.hDC, PChar(di.itemData), lstrlen(PChar(di.itemData)), di.rcItem,
            DT_SINGLELINE or DT_VCENTER);
          MenuBmp(101, di.hDC, 3, 19, hWnd);
        end;
      end;
    end;
    WM_COMMAND:
    begin
      if HiWord(wParam) = 0 then
        case LoWord(wParam) of
          IDM_KUCKUCK: SendMessage(hWnd, WM_CLOSE, 0,0 );
        end;
    end;
    WM_DESTROY: PostQuitMessage(0);
  else
    Result := DefWindowProc(hWnd, uMsg, wParam, lParam);
  end;
end;

var
  wc: TWndClassEx = (
    cbSize : SizeOf(TWndClassEx);
    Style : CS_HREDRAW or CS_VREDRAW;
    lpfnWndProc : @WndProc;
    cbClsExtra : 0;
    cbWndExtra : 0;
    hbrBackground : COLOR_APPWORKSPACE;
    lpszMenuName : nil;
    lpszClassName : ClassName;
    hIconSm : 0;
  );
  msg: TMsg;
begin
  wc.hInstance := hInstance;
  wc.hIcon := LoadIcon(0, IDI_APPLICATION);
  wc.hCursor := LoadCursor(0, IDC_ARROW);

  RegisterClassEx(wc);
  CreateWindowEx(0, ClassName, AppName, WS_CAPTION or WS_VISIBLE or
    WS_SYSMENU, Integer(CW_USEDEFAULT),Integer(CW_USEDEFAULT), WindowWidth,
    WindowHeight, 0, 0, hInstance, nil);

  while true do
  begin
    if not GetMessage(msg, 0, 0, 0) then
      break;
    begin
      TranslateMessage(msg);
      DispatchMessage(msg);
    end;
  end;
  ExitCode := msg.wParam;
end.
Gruß vom KodeZwerg
  Mit Zitat antworten Zitat