7,785
社区成员




'* ****************************************** *
'* 程序说明:一个可在屏幕上拖动的十字架 *
'* 作者: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
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_Load()
WindowState = 2
MousePointer = 0
ScaleMode = vbPixels
BackColor = vbRed '十字条线条颜色
SetWindowLong hwnd, GWL_STYLE, WS_BORDER Or WS_MINIMIZE Or WS_SYSMENU
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