用VB编写的一个可在屏幕上移动的十字架

前几天一位朋友问如何绘制一个可在屏幕上移动的十字架，俺编写了一个，后来又有朋友问到这个问题，故把代码贴了出来，供大家指正：

'* ****************************************** * '* 程序说明：一个可在屏幕上拖动的十字架 * '* 作者：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 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 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 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,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,SWP_NOMOVE Or SWP_NOSIZE End Sub Private Sub Form_LostFocus() SetWindowPos Me.hwnd,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,y As Single) If Button = 0 Then MousePointer = IIf(CBool(PtInRect(hLine,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,y As Single) If Button = 1 And bAdjust Then Dim tRgn As Long If MousePointer = 7 Then OffsetRect hLine,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.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,ScaleHeight / 2,ScaleWidth,ScaleHeight / 2 + 1 SetRect vLine,ScaleWidth / 2,ScaleWidth / 2 + 1,ScaleHeight hhRgn = CreateRectRgn(hLine.Left,hLine.Bottom) hvRgn = CreateRectRgn(vLine.Left,vLine.Bottom) tRgn = CreateRectRgn(hLine.Left,hLine.Bottom) Call CombineRgn(tRgn,RGN_OR) Call SetWindowRgn(hwnd,True) DeleteObject tRgn End Sub Private Sub Form_Unload(Cancel As Integer) DeleteObject hhRgn DeleteObject hvRgn End Sub

程序效果如下：

（编辑：李大同）

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