用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, Shift As Integer, X As Single, Y As Single)
    If Button <> 1 Then Exit Sub
    DrawRect X, Y
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, 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_ptStart.X, m_ptStart.Y, m_ptEnd.X, 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_ptStart.X, m_ptStart.Y, m_ptEnd.X, m_ptEnd.Y
    '绘制新的选取框
    m_idxPen = m_idxPen + 1
    If m_idxPen = 3 Then m_idxPen = 0
    SelectObject Me.hdc, m_hPen(m_idxPen)
    Rectangle m_hDC, m_ptStart.X, m_ptStart.Y, m_ptEnd.X, m_ptEnd.Y
    Me.DrawMode = nOldROP2
End Sub

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

---

更多精彩>>>