'* ****************************************** *
'* 程序说明：一个可在屏幕上拖动的十字架       *
'* 作者：lyserver                             *
'* ****************************************** *
Option Explicit

Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Const RGN_OR = 2
Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
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
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_STYLE = (-16)
Private Const WS_BORDER = &H800000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_SYSMENU = &H80000
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const SWP_SHOWWINDOW = &H40
Private Const HWND_TOPMOST = -1

Dim bAdjust As Boolean
Dim hLine As RECT, vLine As RECT
Dim hhRgn As Long, hvRgn As Long
Dim startX As Long, startY As Long

Private Sub Form_Deactivate()
    SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
    Me.Refresh
End Sub

Private Sub Form_Load()
    WindowState = 2
    MousePointer = 0
    ScaleMode = vbPixels
    BackColor = vbRed '十字条线条颜色
    SetWindowLong hwnd, GWL_STYLE, WS_BORDER Or WS_MINIMIZE Or WS_SYSMENU
    SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End Sub

Private Sub Form_LostFocus()
    SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
    Me.Refresh
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 1 Then
        bAdjust = True
        startX = x
        startY = y
        MousePointer = IIf(CBool(PtInRect(hLine, x + 1, y + 1)), 7, 9)
        SetCapture hwnd
    End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 0 Then
        MousePointer = IIf(CBool(PtInRect(hLine, x + 1, y + 1)), 7, 9)
    ElseIf Button = 1 Then
        If Not bAdjust Then
            bAdjust = True
            startX = x
            startY = y
            SetCapture hwnd
        End If
    End If
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 1 And bAdjust Then
        Dim tRgn As Long
        If MousePointer = 7 Then
            OffsetRect hLine, 0, y - startY
            hhRgn = CreateRectRgn(hLine.Left, hLine.Top, hLine.Right, hLine.Bottom)
        Else
            OffsetRect vLine, x - startX, 0
            hvRgn = CreateRectRgn(vLine.Left, vLine.Top, vLine.Right, vLine.Bottom)
        End If
        tRgn = CreateRectRgn(hLine.Left, hLine.Top, hLine.Right, hLine.Bottom)
        Call CombineRgn(tRgn, hhRgn, hvRgn, RGN_OR)
        Call SetWindowRgn(hwnd, tRgn, True)
        DeleteObject tRgn
        startX = x
        startY = y
        bAdjust = False
    End If
    ReleaseCapture
    MousePointer = 0
End Sub

Private Sub Form_Resize()
    Dim tRgn As Long

SetRect hLine, 0, ScaleHeight / 2, ScaleWidth, ScaleHeight / 2 + 1
    SetRect vLine, ScaleWidth / 2, 0, ScaleWidth / 2 + 1, ScaleHeight
    hhRgn = CreateRectRgn(hLine.Left, hLine.Top, hLine.Right, hLine.Bottom)
    hvRgn = CreateRectRgn(vLine.Left, vLine.Top, vLine.Right, vLine.Bottom)
    tRgn = CreateRectRgn(hLine.Left, hLine.Top, hLine.Right, hLine.Bottom)
    Call CombineRgn(tRgn, hhRgn, hvRgn, RGN_OR)
    Call SetWindowRgn(hwnd, tRgn, True)
    DeleteObject tRgn
End Sub

Private Sub Form_Unload(Cancel As Integer)
    DeleteObject hhRgn
    DeleteObject hvRgn
End Sub