Question

vb在窗体上绘制虚线框

要使虚线框在顶层 可以跨越控件 就像VB在编辑模式下拉选窗体上控件那样的
或许是在屏幕上绘制的?
如果是在屏幕上绘制 请返回左上角和右下角的坐标
就是随着鼠标移动绘制的那种..

Answer 1

画两个线条控件一竖一横，在鼠标移动事件里调用此两控件到当前鼠标事件里得到的坐标上。

Answer 2

分二步:
一.建立一个模块，复制下面代码:
Option Explicit
Private Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetROP2 Lib "GDI32" (ByVal hdc As Long, ByVal nDrawMode As Long) As Long
Private Declare Function CreatePen Lib "GDI32" (ByVal nPenStyle&, ByVal nWidth&, ByVal crColor&) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex&) As Long
Private Declare Function SaveDC Lib "GDI32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "GDI32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetStockObject Lib "GDI32" (ByVal nIndex&) As Long
Private Declare Function Rectangle Lib "GDI32" (ByVal hdc&, ByVal X1&, ByVal Y1&, ByVal X2&, ByVal Y2&) As Long
Private Declare Function RestoreDC Lib "GDI32" (ByVal hdc As Long, ByVal nSavedDC As Long) As Long
Private Declare Function DeleteObject Lib "GDI32" (ByVal hObject&) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Sub InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Any, ByVal bErase As Long)
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As PointAPI) As Long

Private Const SM_CXBORDER = 5
Private Const NULL_BRUSH = 5
Private Const R2_NOT = 6
Private Const PS_INSIDEFRAME = 6
Private Const IDC_CROSS = 32515&
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Type PointAPI
X As Long
Y As Long
End Type

Private pl_hWnd As Long, P1 As PointAPI, P2 As PointAPI, OldPos As PointAPI, lu_RECT As RECT

Public Sub BeginDrawRct(ByVal hwnd As Long)
If pl_hWnd Then HighlightWindow
pl_hWnd = hwnd
GetCursorPos P1
ScreenToClient pl_hWnd, P1
With lu_RECT
.Top = P1.Y
.Left = P1.X
.Right = .Left
.Bottom = .Top
End With
HighlightWindow
End Sub

Public Function DrawRcting() As RECT
HighlightWindow '清除旧框
GetCursorPos P2
ScreenToClient pl_hWnd, P2
With lu_RECT
.Top = IIf(P2.Y > P1.Y, P1.Y, P2.Y)
.Left = IIf(P2.X > P1.X, P1.X, P2.X)
.Right = .Left + Abs(P2.X - P1.X)
.Bottom = .Top + Abs(P2.Y - P1.Y)
End With
HighlightWindow '画新框
DrawRcting = lu_RECT
End Function

Public Sub EndDrawRct()
HighlightWindow
pl_hWnd = 0
End Sub

Private Sub HighlightWindow()

'高亮窗口
Dim ll_hDC As Long
Dim ll_Pen As Long
Dim ll_OldPen As Long
Dim ll_OldBrush As Long
If pl_hWnd = 0 Then Exit Sub
'给出窗口矩形
'GetWindowRect pl_hWnd, lu_RECT
'给出窗口的设备名 DC
ll_hDC = GetWindowDC(pl_hWnd)

SetROP2 ll_hDC, R2_NOT '设置DC的颜色，备以后移去时使用

'建立画笔
ll_Pen = CreatePen(PS_INSIDEFRAME, 3 * GetSystemMetrics(SM_CXBORDER), RGB(0, 0, 0))

'开始增亮窗口边框
Call SaveDC(ll_hDC) '保存画笔和刷子
Call SelectObject(ll_hDC, ll_Pen) '设置新笔
Call SelectObject(ll_hDC, GetStockObject(NULL_BRUSH)) '设备空刷子，背景不能修改

'画窗口边框
Rectangle ll_hDC, lu_RECT.Left, lu_RECT.Top, lu_RECT.Right, lu_RECT.Bottom

'恢复DC设备
Call RestoreDC(ll_hDC, -1) '-1时恢复以前的内容

'释放
ReleaseDC pl_hWnd, ll_hDC
DeleteObject ll_Pen
'刷新屏幕,移动矩形框
'InvalidateRect 0, 0, True

End Sub
二.调用举例:
在窗体上加入控件Picture1,Label1(在Picture1外),为了检验效果,可在Picture1加入其它控件.
复制下面代码到窗体代码区:
Option Explicit
Dim Msd As Boolean, Rct As RECT

Private Sub Command1_Click()
EndDrawRct
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
Msd = True
BeginDrawRct Picture1.hwnd
End If
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Msd = True And Button = 1 Then
Rct = DrawRcting
Label1 = "选择框的范围:" & Rct.Left & "," & Rct.Top & "," & Rct.Right & "," & Rct.Bottom '返回选择框的范围
End If
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Msd = False
End Sub
然后运行本程序,在Picture1内按住鼠标左键不放,拉出一个矩形框,即可看到效果.

Answer 3

建议学习一下GDI函数，只有这个能完全达到你的要求

追问

GDI不是命令与征服吗?