代码如下:
- program Project2;
- {$APPTYPE CONSOLE}
- {$R *.res}
- uses
- System.SysUtils,
- Windows,
- Winapi.Messages,
- Vcl.Dialogs;
- var
- swndClass: tagWNDCLASS;
- message: MSG;
- mHwnd: hwnd;
- cxChar, cyChar: Integer;
- cxClient, cyClient: Integer;
- ScrollPos: Integer = 0;
- function WindowProc(hwnd: hwnd; uMsg: UINT; wParam: wParam; lParam: lParam): LRESULT; stdcall;
- var
- i: integer;
- uHdc: HDC;
- ps: tagPAINTSTRUCT;
- tm: tagTEXTMETRIC;
- str: string;
- begin
- case uMsg of
- WM_CREATE:
- begin
{获取文本尺寸}
- uHdc := GetDC(hwnd);
- GetTextMetrics(uHdc, tm);
- ReleaseDC(hwnd, uHdc);
- cxChar := tm.tmAveCharWidth;
- cyChar := tm.tmHeight + tm.tmExternalLeading;
{设置滚动条最大位置}
- SetScrollRange(hwnd, SB_VERT, 0, 100, False);
- SetScrollPos(hwnd, SB_VERT, 20, True);
- end;
- WM_SIZE:
- begin
- cxClient := loword(lParam);
- cyClient := HiWord(lParam);
- end;
- WM_PAINT:
- begin
- uHdc := BeginPaint(hwnd, ps);
- for i := ScrollPos to 100 do
- begin
- str := 'Hello world num:' + i.ToString;
- TextOut(uHdc, 0, (i - ScrollPos) * cychar, PWideChar(str), Length(str));
- end;
- EndPaint(hwnd, ps);
- end;
- WM_VSCROLL:
- begin
- case LOWORD(wParam) of
- SB_BOTTOM:
- begin
{滚动到底端}
- scrollpos := 100;
- end;
- SB_ENDSCROLL:
- begin
{完成滚动, 松开鼠标}
- //scrollpos := hiword(wParam);
- end;
- SB_LINEDOWN:
- begin
{向下滚动一行}
- Inc(ScrollPos);
- end;
- SB_LINEUP:
- begin
{向上滚动一行}
- Dec(ScrollPos);
- end;
- SB_PAGEDOWN:
- begin
{向下滚动一页}
- scrollpos := scrollpos + (cyclient div cyChar);
- end;
- SB_PAGEUP:
- begin
{向上滚动一页}
- scrollpos := scrollpos - (cyclient div cyChar);
- end;
- SB_THUMBPOSITION:
- begin
{用户拖动滚动条, 且松开鼠标}
- scrollpos := hiword(wParam);
- end;
- SB_THUMBTRACK:
- begin
{用户正在拖动滚动条}
- scrollpos := hiword(wParam);
- end;
- sb_top:
- begin
{滚动条到顶端}
- scrollpos := 0;
- end;
- end;
{限制最大值, 最小值}
- if ScrollPos <0 then
- begin
- scrollpos := 0;
- end;
- if ScrollPos> 100 then
- begin
- scrollpos := 100;
- end;
{有改动才更新}
- if ScrollPos <> GetScrollPos(hwnd, SB_VERT) then
- begin
- SetScrollPos(hwnd, SB_VERT, ScrollPos, true);
- InvalidateRect(hwnd, nil, true);
- end;
- end;
- end;
- result := DefWindowProc(hwnd, uMsg, wParam, lParam);
- end;
- begin
- swndClass.cbClsExtra := 0; // 窗口类扩展, 无
- swndClass.cbWndExtra := 0; // 窗口实例扩展
- swndClass.hbrBackground := COLOR_BACKGROUND; // 窗口背景颜色黑色
- //LoadCursor()
- swndClass.hCursor := LoadCursor(0, IDC_ARROW); // 窗口采用箭头光标
- swndClass.hIcon := LoadIcon(0, IDI_APPLICATION); // 窗口最小化图标: 采用缺省图标
- swndClass.hInstance := hInstance; // 窗口实例句柄
- swndClass.lpfnWndProc := @WindowProc; // 窗口处理函数
- swndClass.lpszClassName := 'myWnd'; // 窗口类名
- swndClass.lpszMenuName := nil; // 窗口菜单
- swndClass.style := CS_DBLCLKS; // 窗口样式
- if RegisterClass(swndClass) = 0 then
- begin
- Writeln('Windows class register error!');
- Exit;
- end;
mHwnd := CreateWindowEx(0, 'myWnd', 'Delphi Windows', WS_OVERLAPPEDWINDOW or WS_VSCROLL or WS_HSCROLL, {滚动条添加}
- CW_USEDEFAULT, CW_USEDEFAULT, 544, 375, HWND_DESKTOP, 0, hInstance, 0);
- ShowWindow(mHwnd, SW_SHOW);
- UpdateWindow(mHwnd);
- while GetMessage(message, 0, 0, 0) do
- begin
- TranslateMessage(message);
- DispatchMessage(message);
- end;
- end.
来源: http://www.bubuko.com/infodetail-2795794.html