|
|
发表于 2005-11-16 12:12:00
|
显示全部楼层
Re:问大家一个VB编程问题
我认为如果仅用来开发游戏，不用FORM最好，如果要用就一个就够了，其它的多定义几个内存DC吧。个人认为模块最好。就是SDK的方式。如下代码，是我以前写控件时加的ToolTip窗口：）
-------------------------------------------------------------------------------------------------------------------
'////////////////////////////////////////////////////////////////////////////////////
Global Const TOOLTIP_CLASS As String = "_________Tooltip_Hyh______________"
Global g_hTooltip As Long ' global handle to tooltip
Global g_rcTooltipWnd As RECT
Global g_bTooltipFixed As Boolean
Private m_rcParent As RECT
Private m_rcText As RECT
Private m_rcFixed As RECT
Private m_hOwner As Long
Private m_sTooltip As String
Private m_hFont As Long
Private m_hPen As Long
Private m_hBrush As Long
Private m_hBmpFixBtn As Long
Private m_nTextColor As Long
Private m_nBackColor As Long
Private m_nPolygonColor As Long
Private m_ptPolygon(2) As POINTAPI
Private m_hOldCapture As Long
'///////////////////////////////////////////////////////////////////////////////////
'
' Show a tooltip window for specified application
'
' by Dreamerate, 2005/09/22
'
'///////////////////////////////////////////////////////////////////////////////////
Public Function ShowTooltip(ByVal hOwner As Long, _
ByVal sTooltip As String, _
Optional ByVal b3DFrame As Boolean, _
Optional ByVal nTextColor As Long = -1, _
Optional ByVal nBackColor As Long = -1, _
Optional ByVal nPolygonColor As Long = -1, _
Optional ByVal nPolygonContour As Long = 4, _
Optional ByVal nLeftMargin As Long = 3, _
Optional ByVal nTopMargin As Long = 16, _
Optional ByVal nRightMargin As Long = 6, _
Optional ByVal nBottomMargin As Long = 12 _
) As Long
Dim wc As WNDCLASSEX
Dim pmsg As MSGAPI
Dim pt As POINTAPI
Dim nBottom As Long
Dim nRight As Long
Dim nLineHeight As Long
Dim szScreen As SIZEAPI 'Size of Screen
Dim szTooltip As SIZEAPI 'Size of Tooltip text
Dim nWndStyle As Long
Dim nExWndStyle As Long
' Close it first if has been to created
DestroyTooltip
' Backup
'
m_hOwner = hOwner
m_sTooltip = sTooltip
If nTextColor = -1 Then
m_nTextColor = GetSysColor(COLOR_INFOTEXT)
Else
m_nTextColor = nTextColor
End If
If nBackColor = -1 Then
m_nBackColor = GetSysColor(COLOR_INFOBK)
Else
m_nBackColor = nBackColor
End If
If nPolygonColor = -1 Then
m_nPolygonColor = vbRed
Else
m_nPolygonColor = nPolygonColor
End If
'...
' Default
SetRect m_rcText, 0, 0, 200, 60
' Calculate the text info
nLineHeight = CalcuRectSize(hOwner, sTooltip, m_rcText, szTooltip, m_hFont)
' Make Tooltip window class structure
With wc
.cbSize = Len(wc)
.style = CS_HREDRAW Or CS_VREDRAW
.lpfnWndProc = FARPROC(AddressOf WndProc)
.cbClsExtra = 0
.cbWndExtra2 = 0
.hInstance = App.hInstance
.hIcon = 0
.hCursor = LoadCursor(0, IDC_ARROW)
.hbrBackground = CreateSolidBrush(m_nBackColor)
.lpszClassName = TOOLTIP_CLASS
.lpszMenuName = 0
.hIconSm = 0
End With
'先删除，再注册
UnregisterClass TOOLTIP_CLASS, App.hInstance
'再注册
If RegisterClassEx(wc) = 0 Then
Exit Function
End If
'获取当前光标以及屏幕大小
GetCursorPos pt
szScreen.cx = GetSystemMetrics(SM_CXSCREEN)
szScreen.cy = GetSystemMetrics(SM_CYSCREEN)
GetWindowRect hOwner, m_rcParent
' 设定窗口区域大小, 创建
With m_rcText
.Left = nLeftMargin ' left margin
.Top = nTopMargin ' top margin
.Bottom = .Bottom + nBottomMargin ' bottom margin
' at least need five lines
If .Bottom < nLineHeight * 5 Then
.Bottom = nLineHeight * 5
End If
' right margin
.Right = .Right + nRightMargin
If b3DFrame Then
.Right = .Right + 3
End If
' at least need 180 width
If .Right < 180 Then
.Right = 180
End If
' total length
nRight = pt.X + .Right
nBottom = pt.Y + .Bottom
' Readjust
If nRight > szScreen.cx Then
pt.X = pt.X - nRight + szScreen.cx - nRightMargin
If b3DFrame Then
pt.X = pt.X - 3
End If
End If
If nBottom > szScreen.cy Then
pt.Y = pt.Y - nBottom + szScreen.cy - nRightMargin
End If
'...
'设定描绘多边形之坐标点
m_ptPolygon(0).X = -1
m_ptPolygon(0).Y = -1
m_ptPolygon(1).X = -1
m_ptPolygon(1).Y = nPolygonContour
m_ptPolygon(2).X = nPolygonContour
m_ptPolygon(2).Y = -1
If b3DFrame Then
m_ptPolygon(1).Y = m_ptPolygon(1).Y + 3
m_ptPolygon(2).X = m_ptPolygon(2).X + 3
End If
'设置窗口扩展样式
nWndStyle = WS_POPUP Or WS_BORDER
nExWndStyle = WS_EX_TOOLWINDOW Or WS_EX_TOPMOST
If b3DFrame Then
nExWndStyle = nExWndStyle Or WS_EX_DLGMODALFRAME
End If
'窗口位于屏幕的矩形
SetRect g_rcTooltipWnd, pt.X, pt.Y, pt.X + .Right, pt.Y + .Bottom
SetRect m_rcFixed, .Right - 18, 0, .Right, 15
'创建Tooltip窗口
g_hTooltip = CreateWindowEx(nExWndStyle, _
TOOLTIP_CLASS, _
"Tooltip by HYH", _
nWndStyle, _
pt.X, _
pt.Y, _
.Right, _
.Bottom, _
hOwner, _
0, _
App.hInstance, _
ByVal 0&)
End With
' exit it if create window failed
If g_hTooltip = 0 Then
Exit Function
End If
Call ShowWindow(g_hTooltip, SW_SHOWNOACTIVATE)
Call UpdateWindow(g_hTooltip)
'// Main message loop:
While (GetMessage(pmsg, 0, 0, 0))
Call TranslateMessage(pmsg)
Call DispatchMessage(pmsg)
Wend
' // result
ShowTooltip = g_hTooltip
End Function
Public Function FARPROC(ByVal lpfn As Long) As Long
FARPROC = lpfn
End Function
'Tooltip window procedure
Public Function WndProc(ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Select Case uMsg
' 初始化窗口
Case WM_CREATE
m_hPen = CreatePen(PS_SOLID, 1, m_nPolygonColor)
m_hBrush = CreateSolidBrush(m_nPolygonColor)
m_hBmpFixBtn = LoadImage(App.hInstance, ByVal 201&, IMAGE_BITMAP, 0, 0, _
LR_CREATEDIBSECTION)
' m_hBmpFixBtn = LoadImage(0, ByVal "res\\fixbutton.bmp", IMAGE_BITMAP, 0, 0, _
' LR_CREATEDIBSECTION Or LR_LOADFROMFILE)
m_hBmpFixBtn = MakeBitmapEx(m_hBmpFixBtn, , m_nBackColor)
WndProc = 1
' 描述 工具条
Case WM_PAINT
Dim ps As PAINTSTRUCT
Call BeginPaint(hwnd, ps)
SetBkMode ps.hDC, TRANSPARENT
SetBkColor ps.hDC, m_nBackColor
SetTextColor ps.hDC, m_nTextColor
SetPolyFillMode ps.hDC, WINDING
If GetCurrentObject(ps.hDC, OBJ_FONT) <> m_hFont Then
SelectObject ps.hDC, m_hFont
End If
If GetCurrentObject(ps.hDC, OBJ_PEN) <> m_hPen Then
SelectObject ps.hDC, m_hPen
End If
If GetCurrentObject(ps.hDC, OBJ_BRUSH) <> m_hBrush Then
SelectObject ps.hDC, m_hBrush
End If
'draw polygon on left top of window
Polygon ps.hDC, m_ptPolygon(0), 3
'draw text
DrawText ps.hDC, m_sTooltip, lstrlen(m_sTooltip), m_rcText, DT_WORDBREAK
'RedrawTopRightFixedButton ps.hDC
Call EndPaint(hwnd, ps)
WndProc = 1
Case WM_MOUSEMOVE
' Dim pt As POINTAPI
' Dim hCur As Long
'
' GetCursorPos pt
' hCur = WindowFromPoint(pt.X, pt.Y)
'
' If hCur <> hwnd And hCur <> m_hOwner And GetCurrentLine() <> m_nCurLinePos Then
' Call DestroyTooltip
' End If
' Presses the left mouse button while the cursor is in the client area
' of a window.
Case WM_LBUTTONDOWN, WM_RBUTTONDOWN
'ReleaseCapture
' If PtInRect(m_rcFixed, LOWORD(lParam), HIWORD(lParam)) Then
' g_bTooltipFixed = Not g_bTooltipFixed
' RedrawTopRightFixedButton
' If g_bTooltipFixed Then
' If GetCapture() = g_hTooltip Then
' ReleaseCapture
' SetCapture m_hOldCapture
' End If
' Else
' SetCapture g_hTooltip
' End If
' Else
' Call DestroyTooltip
' End If
WndProc = 1
Case WM_SHOWWINDOW
' m_hOldCapture = GetCapture
' SetCapture hwnd
WndProc = 1
Case WM_DESTROY
PostQuitMessage (0)
DeleteObject m_hFont
DeleteObject m_hPen
DeleteObject m_hBrush
DeleteObject m_hBmpFixBtn
m_hFont = 0
m_hPen = 0
m_hBrush = 0
m_hBmpFixBtn = 0
g_hTooltip = 0
m_hOldCapture = 0
m_sTooltip = ""
Case Else
WndProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
End Select
End Function
Private Sub RedrawTopRightFixedButton(Optional ByVal hDCSpecified As Long = 0)
Dim hDC As Long
Dim hDCMemory As Long
Dim xSrc As Long
If hDCSpecified = 0 Then
hDC = GetDC(g_hTooltip)
Else
hDC = hDCSpecified
End If
hDCMemory = CreateCompatibleDC(hDC)
SelectObject hDCMemory, m_hBmpFixBtn
If g_bTooltipFixed Then
xSrc = 17
Else
xSrc = 0
End If
BitBlt hDC, m_rcFixed.Left, m_rcFixed.Top, 16, 16, hDCMemory, xSrc, 0, vbSrcCopy
If hDCSpecified = 0 Then
ReleaseDC g_hTooltip, hDC
End If
DeleteDC hDCMemory
End Sub
Public Function CalcuRectSize(ByVal hwnd As Long, _
ByVal sText As String, _
ByRef lprc As RECT, _
ByRef lpSize As SIZEAPI, _
ByRef hFont As Long) As Long
Dim hDC As Long
Dim tm As TEXTMETRIC
Dim hOldFont As Long
Dim lf As LOGFONT
hDC = GetDC(hwnd)
With lf
'height method of calculatation
.lfHeight = -MulDiv(9, GetDeviceCaps(hDC, LOGPIXELSY), 72)
.lfWidth = 0
.lfEscapement = 0
.lfOrientation = 0
.lfWeight = FW_NORMAL 'FW_BOLD
.lfItalic = 0
.lfStrikeOut = 0
.lfUnderline = 0
.lfCharSet = DEFAULT_CHARSET
.lfClipPrecision = CLIP_DEFAULT_PRECIS
.lfOutPrecision = OUT_DEFAULT_PRECIS
.lfQuality = DEFAULT_QUALITY
.lfPitchAndFamily = DEFAULT_PITCH Or FF_DONTCARE
Call lstrcpy(.lfFaceName(0), "宋体")
End With
hFont = CreateFontIndirect(lf)
hOldFont = SelectObject(hDC, hFont)
' to calculate the text size info.
DrawText hDC, sText, lstrlen(sText), lprc, DT_CALCRECT Or DT_WORDBREAK
If GetTextMetrics(hDC, tm) <> 0 Then
CalcuRectSize = tm.tmHeight
End If
GetTextExtentPoint32 hDC, sText, lstrlen(sText), lpSize
Call SelectObject(hDC, hOldFont)
ReleaseDC hwnd, hDC
End Function
'close it first if has been to created
Public Sub DestroyTooltip()
If g_hTooltip And Not g_bTooltipFixed Then
' ReleaseCapture
' If m_hOldCapture Then
' SetCapture m_hOldCapture
' End If
SendMessage g_hTooltip, WM_CLOSE, 0, ByVal 0&
End If
End Sub
'////////////////////////////////////////////////////////////////////////////////////////
'// |
|
楼主
