📄 frm3_1.frm
字号:
VERSION 5.00
Begin VB.Form Form1
BackColor = &H00C0C0C0&
BorderStyle = 3 'Fixed Dialog
Caption = "Form1"
ClientHeight = 5310
ClientLeft = 45
ClientTop = 330
ClientWidth = 5730
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 5310
ScaleWidth = 5730
ShowInTaskbar = 0 'False
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdSubtract
Caption = "Rect2=Rect2-Rect1"
Height = 315
Index = 1
Left = 3240
TabIndex = 13
Top = 4800
Width = 2415
End
Begin VB.CommandButton cmdSubtract
Caption = "Rect1=Rect1-Rect2"
Height = 315
Index = 0
Left = 3240
TabIndex = 12
Top = 4440
Width = 2415
End
Begin VB.CommandButton cmdShow
Caption = "Show Intersect rect"
Height = 315
Index = 1
Left = 3240
TabIndex = 11
Top = 3900
Width = 2415
End
Begin VB.CommandButton cmdShow
Caption = "Show union rect"
Height = 315
Index = 0
Left = 3240
TabIndex = 10
Top = 3540
Width = 2415
End
Begin VB.CommandButton ComCopy
Caption = "Set Rect2=Rect1"
Height = 315
Index = 1
Left = 1320
TabIndex = 9
Top = 3900
Width = 1815
End
Begin VB.CommandButton ComCopy
Caption = "Set Rect1=Rect2"
Height = 315
Index = 0
Left = 1320
TabIndex = 8
Top = 3540
Width = 1815
End
Begin VB.CommandButton Command1
Caption = "SetEmpty"
Height = 315
Left = 2040
TabIndex = 7
Top = 4800
Width = 1095
End
Begin VB.Timer Timer1
Enabled = 0 'False
Interval = 50
Left = 5040
Top = 360
End
Begin VB.CommandButton ComRectMove
Caption = "→"
Height = 375
Index = 2
Left = 1260
TabIndex = 6
Top = 4740
Width = 495
End
Begin VB.CommandButton ComRectMove
Caption = "↓"
Height = 375
Index = 3
Left = 720
TabIndex = 5
Top = 4740
Width = 495
End
Begin VB.CommandButton ComRectMove
Caption = "↑"
Height = 375
Index = 1
Left = 720
TabIndex = 4
Top = 4320
Width = 495
End
Begin VB.CommandButton ComRectMove
Caption = "←"
Height = 375
Index = 0
Left = 180
TabIndex = 3
Top = 4740
Width = 495
End
Begin VB.OptionButton OptRect
BackColor = &H00C0C0C0&
Caption = "Rect2"
ForeColor = &H0000FF00&
Height = 195
Index = 1
Left = 180
TabIndex = 2
Top = 3840
Width = 1095
End
Begin VB.OptionButton OptRect
BackColor = &H00C0C0C0&
Caption = "Rect1"
ForeColor = &H000000FF&
Height = 195
Index = 0
Left = 180
TabIndex = 1
Top = 3600
Value = -1 'True
Width = 1095
End
Begin VB.PictureBox Picture1
BackColor = &H00FFFFFF&
Height = 3435
Left = 0
ScaleHeight = 3375
ScaleWidth = 5655
TabIndex = 0
Top = 0
Width = 5715
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'program3 by Xing 3/29/1999
Private Declare Function CopyRect& Lib "user32" (lpDestRect As RECT, lpSourceRect As RECT)
Private Declare Function EqualRect& Lib "user32" (lpRect1 As RECT, lpRect2 As RECT)
Private Declare Function InflateRect& Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long)
Private Declare Function IntersectRect& Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT)
Private Declare Function IsRectEmpty& Lib "user32" (lpRect As RECT)
Private Declare Function OffsetRect& Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long)
Private Declare Function PtInRect& Lib "user32" (lpRect As RECT, ByVal ptx As Long, ByVal pty As Long)
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)
Private Declare Function SetRectEmpty& Lib "user32" (lpRect As RECT)
Private Declare Function SubtractRect& Lib "user32" (lprcDst As RECT, lprcSrc1 As RECT, lprcSrc2 As RECT)
Private Declare Function UnionRect& Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT)
Private Type RECT
left As Long
top As Long
right As Long
bottom As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private IntDx As Integer, IntDy As Integer '移动矩形的偏移量
Private StartPoint As POINTAPI
Private EndPoint As POINTAPI
Private MyRect1 As RECT
Private MyRect2 As RECT
Private Sub cmdShow_Click(Index As Integer)
Dim TempRect As RECT
Dim dl&
Dim OldColor As OLE_COLOR
Call PaintRect
Select Case Index
Case 0
dl& = UnionRect(TempRect, MyRect1, MyRect2)
Case 1
dl& = IntersectRect(TempRect, MyRect1, MyRect2)
End Select
OldColor = Picture1.ForeColor
Picture1.ForeColor = vbBlack
Picture1.DrawMode = vbCopyPen
Picture1.Line (TempRect.left, TempRect.top)-(TempRect.right, TempRect.bottom), , B
Picture1.DrawMode = vbNotXorPen
Picture1.ForeColor = OldColor
End Sub
Private Sub cmdSubtract_Click(Index As Integer)
Dim dl&
If Index = 0 Then
dl& = SubtractRect(MyRect1, MyRect1, MyRect2)
Else
dl& = SubtractRect(MyRect2, MyRect2, MyRect1)
End If
Call PaintRect
End Sub
Private Sub ComCopy_Click(Index As Integer)
Dim dl&
If Index = 0 Then
dl& = CopyRect(MyRect1, MyRect2)
Else
dl& = CopyRect(MyRect2, MyRect1)
End If
Call PaintRect
End Sub
Private Sub Command1_Click()
Dim dl&
If OptRect(0) Then
dl& = SetRectEmpty(MyRect1)
Else
dl& = SetRectEmpty(MyRect2)
End If
Call PaintRect
End Sub
Private Sub ComRectMove_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Select Case Index
Case 0
IntDx = -1: IntDy = 0
Case 1
IntDx = 0: IntDy = -1
Case 2
IntDx = 1: IntDy = 0
Case 3
IntDx = 0: IntDy = 1
End Select
Timer1.Enabled = True
End Sub
Private Sub ComRectMove_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Timer1.Enabled = False
Call PaintRect
End Sub
Private Sub Form_Load()
Form1.ScaleMode = vbPixels
Picture1.ScaleMode = vbPixels
Picture1.DrawMode = vbNotXorPen
Picture1.ForeColor = vbRed
End Sub
Private Sub OptRect_Click(Index As Integer)
If Index = 0 Then
Picture1.ForeColor = vbRed
Else
Picture1.ForeColor = vbGreen
End If
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
StartPoint.X = X: StartPoint.Y = Y
EndPoint.X = X: EndPoint.Y = Y
Picture1.Line (StartPoint.X, StartPoint.Y)-(EndPoint.X, EndPoint.Y), , B
End If
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
Picture1.Line (StartPoint.X, StartPoint.Y)-(EndPoint.X, EndPoint.Y), , B
EndPoint.X = X: EndPoint.Y = Y
Picture1.Line (StartPoint.X, StartPoint.Y)-(EndPoint.X, EndPoint.Y), , B
End If
End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim dl&
If Button = vbLeftButton Then
If OptRect(0).Value Then
dl& = SetRect(MyRect1, StartPoint.X, StartPoint.Y, X, Y)
Else
dl& = SetRect(MyRect2, StartPoint.X, StartPoint.Y, X, Y)
End If
Call PaintRect
End If
End Sub
Private Sub PaintRect() '重画两个矩形
Dim OldColor As OLE_COLOR
Picture1.Cls
OldColor = Picture1.ForeColor
If Not IsRectEmpty(MyRect1) Then
Picture1.ForeColor = vbRed
Picture1.Line (MyRect1.left, MyRect1.top)-(MyRect1.right, MyRect1.bottom), , B
End If
Picture1.ForeColor = vbGreen
If Not IsRectEmpty(MyRect2) Then
Picture1.Line (MyRect2.left, MyRect2.top)-(MyRect2.right, MyRect2.bottom), , B
End If
Picture1.ForeColor = vbBlack
If EqualRect(MyRect1, MyRect2) Then
Picture1.CurrentX = 90
Picture1.CurrentY = 0
Picture1.Print "现在，两个矩形完全重叠在一起了"
End If
Picture1.ForeColor = OldColor
End Sub
Private Sub Timer1_Timer() '处理矩形的移动
Dim dl&
If OptRect(0).Value Then
Picture1.Line (MyRect1.left, MyRect1.top)-(MyRect1.right, MyRect1.bottom), , B
dl& = OffsetRect(MyRect1, IntDx, IntDy)
Picture1.Line (MyRect1.left, MyRect1.top)-(MyRect1.right, MyRect1.bottom), , B
Else
Picture1.Line (MyRect2.left, MyRect2.top)-(MyRect2.right, MyRect2.bottom), , B
dl& = OffsetRect(MyRect2, IntDx, IntDy)
Picture1.Line (MyRect2.left, MyRect2.top)-(MyRect2.right, MyRect2.bottom), , B
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -