用VB使用花式画笔实现流动的选取框

创建一个选取框并不难，可以用DrawFocusRect、FrameRgn等API来实现，但要实现一个类似于PS的流动的选取框，相对来说不是一件简单的事。有的朋友干脆使用了若干位图来模拟，但这样做有一个缺点，即二次选择时，由于FrameRgn对NotXor绘图模式无效，从而导致无法轻易地擦除选取框。当然，可以事先将窗口画面保存在内存中，在需要擦除选取框时，再恢复内存中的画面。有没有比这更方便的办法呢？其实很简单，使用花式画笔就能达到目的，并且避免了前面所说的缺点或不足。

需要说明的是，在使用前，需要在窗体上放置一个Timer控件，然后再把代码复制到窗体代码里就可以了。程序运行后，按下左键移动鼠标，将出现一个随着鼠标缩放的虚线选择框，松开鼠标按键后，该虚线选择框将呈现流动状态。此外，你还可以多次进行测试，选择框会自动重新生成。好了，言归正传，请看代码：

Option Explicit '* ************************************************************** * '* 程序名称：frmMarquee.bas '* 程序功能：流动的选取框 '* 作者：lyserver '* 联系方式：http://blog.csdn.net/lyserver '* ************************************************************** * Private Declare Function ExtCreatePen Lib "gdi32" (ByVal dwPenStyle As Long,ByVal dwWidth As Long,lplb As LOGBRUSH,ByVal dwStyleCount As Long,lpStyle As Long) As Long Private Const PS_GEOMETRIC = &H10000 Private Const PS_ENDCAP_FLAT = &H200 Private Const PS_USERSTYLE = 7 Private Type LOGBRUSH lbStyle As Long lbColor As Long lbHatch As Long End Type Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long,ByVal x1 As Long,ByVal y1 As Long,ByVal x2 As Long,ByVal y2 As Long) As Long Private Type POINTAPI X As Long Y As Long End Type Private Declare Function GetCurrentObject Lib "gdi32" (ByVal hdc As Long,ByVal uObjectType As Long) As Long Private Const OBJ_PEN = 1 Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long,ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Dim m_hDC As Long,m_idxPen As Long Dim m_hPen(2) As Long,m_hOldPen As Long Dim m_ptOrigin As POINTAPI,m_ptStart As POINTAPI,m_ptEnd As POINTAPI Private Sub Form_Load() Me.ScaleMode = vbPixels Me.MousePointer = vbCrosshair Me.Timer1.Interval = 160 Me.Timer1.Enabled = False m_hDC = Me.hdc m_hPen(0) = CreatePenEx("0202 2020") m_hPen(1) = CreatePenEx("0220 2002") m_hPen(2) = CreatePenEx("2020 0202") m_hOldPen = GetCurrentObject(m_hDC,OBJ_PEN) m_ptEnd.X = -10000 End Sub Private Sub Form_Unload(Cancel As Integer) Me.Timer1.Enabled = False If m_hOldPen <> 0 Then SelectObject m_hDC,m_hOldPen DeleteObject m_hPen(0) DeleteObject m_hPen(1) DeleteObject m_hPen(2) End Sub Private Sub Form_MouseDown(Button As Integer,Shift As Integer,X As Single,Y As Single) If Button <> 1 Then Exit Sub Me.Timer1.Enabled = False m_ptOrigin.X = X: m_ptOrigin.Y = Y SelectObject Me.hdc,m_hPen(m_idxPen) End Sub Private Sub Form_MouseMove(Button As Integer,Y As Single) If Button <> 1 Then Exit Sub DrawRect X,Y End Sub Private Sub Form_MouseUp(Button As Integer,Y As Single) If Button = 1 Then Me.Timer1.Enabled = True End Sub '辅助函数，绘制矩形选取框 Private Sub DrawRect(ByVal X As Long,ByVal Y As Long) Dim nOldROP2 As Long If X = m_ptEnd.X And Y = m_ptEnd.Y Then Exit Sub nOldROP2 = Me.DrawMode Me.DrawMode = vbNotXorPen '擦除原来的选取框 If m_ptEnd.X <> -10000 Then Rectangle m_hDC,m_ptStart.X,m_ptStart.Y,m_ptEnd.X,m_ptEnd.Y '调整坐标点 If X > m_ptOrigin.X Then m_ptStart.X = m_ptOrigin.X m_ptEnd.X = X + 1 Else m_ptStart.X = X m_ptEnd.X = m_ptOrigin.X End If If Y > m_ptOrigin.Y Then m_ptStart.Y = m_ptOrigin.Y m_ptEnd.Y = Y + 1 Else m_ptStart.Y = Y m_ptEnd.Y = m_ptOrigin.Y End If '绘制新的选取框 Rectangle m_hDC,m_ptEnd.Y Me.DrawMode = nOldROP2 End Sub '辅助函数，创建花式画笔 Private Function CreatePenEx(ByVal strPenStyle As String) As Long Dim lb As LOGBRUSH Dim nPenStyle() As Long Dim i As Integer,nLen As Integer strPenStyle = Replace(strPenStyle," ","") If Not IsNumeric(strPenStyle) Then Exit Function nLen = Len(strPenStyle) ReDim nPenStyle(nLen - 1) For i = 0 To nLen - 1 nPenStyle(i) = Mid(strPenStyle,i + 1,1) Next CreatePenEx = ExtCreatePen(PS_GEOMETRIC Or PS_ENDCAP_FLAT Or PS_USERSTYLE,1,lb,nLen,nPenStyle(0)) End Function Private Sub Timer1_Timer() Dim nOldROP2 As Long If m_ptEnd.X = -10000 Then Exit Sub nOldROP2 = Me.DrawMode Me.DrawMode = vbNotXorPen '擦除原来的选取框 SelectObject m_hDC,m_hPen(m_idxPen) Rectangle m_hDC,m_ptEnd.Y '绘制新的选取框 m_idxPen = m_idxPen + 1 If m_idxPen = 3 Then m_idxPen = 0 SelectObject Me.hdc,m_ptEnd.Y Me.DrawMode = nOldROP2 End Sub

（编辑：李大同）

【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!