Run Time用Mouse移动Line物件
来源:cww

这个技术是属於Region的技术，请先查Mouse是否处於不规则区域内
请先在Form中放数个Line物件，Form_Load时，会看看有多少个Line物件，而依其所在的
座标产生一狭长的条形Region，所以当Mouse移过去时便能得知是否处於某个Region中
我不知道外面的绘图软体是不是也用这种方式来做，不过我们至少在VB也初步完成了

Option Explicit
Private Type POINTAPI
	X As Long
	Y As Long
End Type
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal X As Long, ByVal Y As Long) As Long
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 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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private hreg1 As Long, hreg2 As Long '选取的Line Objec其端点会有两个小正方形
				     '记录这两个正方形的handle of Region
Private haveSel As Boolean '目前是否有Line Object被选取
Private inReg1 As Boolean  '是否在hreg1 的范围
Private inReg2 As Boolean  '是否在hreg2 的范围
Private oldPoint As POINTAPI '记录选取到Line Object时的Mouse座标
Private lp1 As POINTAPI, lp2 As POINTAPI
Private aLine As Line
Private NotRefresh As Boolean
Private PI As Double
Private Sub Form_Load()
Dim ctl As Control, i As Long
Me.ScaleMode = 3
Me.DrawStyle = 0
Me.DrawMode = 13
Me.FillColor = &H808000
Me.FillStyle = 0
Me.ForeColor = &H8000000E

PI = 4 * Atn(1)
For Each ctl In Me
   If TypeOf ctl Is Line Then
      Set aLine = ctl
      Call SetRegion
      i = i + 1
  End If
Next

End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Long, j As Long
Dim hRegion5 As Long
Dim ctl As Control
If Button = 1 Then
   NotRefresh = True
   Me.Refresh '如果先前有画上小框框，於此将之去除
   haveSel = False
   For Each ctl In Me
       If TypeOf ctl Is Line Then
	  hRegion5 = CLng(ctl.Tag)
	  i = PtInRegion(hRegion5, X, Y)
	  If i <> 0 Then
	     Set aLine = ctl
	     Exit For
	  End If
       End If
   Next
   If i <> 0 Then
      oldPoint.X = X
      oldPoint.Y = Y
      Call SetSelect
      haveSel = True
   Else
      haveSel = False
   End If
End If
'虽上面已Check Mouse是否处於某个 line的Region内，但是Line处於Select状态时，
'有画上两个小方框，这两个小方框未必在Region之内，所以User在方框处按Mouse也算有选取
i = PtInRegion(hreg1, X, Y)
j = PtInRegion(hreg2, X, Y)
inReg1 = False: inReg2 = False
If i <> 0 Or j <> 0 Then
   haveSel = True
   'Mouse down时mouse是否处於hreg1/ hreg2, 若是则影响Mouse move时Line的移动
   If i <> 0 Then inReg1 = True
   If j <> 0 Then inReg2 = True
End If
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Long, j As Long
If haveSel Then
   i = PtInRegion(hreg1, X, Y)
   j = PtInRegion(hreg2, X, Y)
End If
If Button = 0 Then
   If i <> 0 Or j <> 0 Then 'Mouse在选取的两个方框内时改变Mouse的形状
      Screen.MousePointer = 2
   Else
      Screen.MousePointer = 0
   End If
Else
   If Button = 1 Then
      If haveSel Then
	 Call MoveLine(X, Y)
      End If
   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 Then
   If haveSel Then '重新设定Line物件的hRegion范围
      Call SetSelect
      Call SetRegion
   End If
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Dim ctl As Control
Dim hRegion5 As Long
For Each ctl In Me
    If TypeOf ctl Is Line Then
       hRegion5 = Val(ctl.Tag)
       DeleteObject hRegion5
    End If
Next
DeleteObject hreg1
DeleteObject hreg2
End Sub
Private Sub Form_Resize()
If Me.WindowState = vbNormal Or Me.WindowState = vbMaximized Then
   If haveSel Then
      DoEvents '等Form show出来
      Call SetSelect '重画小方框
   End If
End If
End Sub

'设定Line物件的hRegion
Private Sub SetRegion()
Dim hregion As Long
Dim pt(3) As POINTAPI
Dim n As Long, dx As Long, dy As Long
Dim sida As Double

hregion = Val(aLine.Tag)
DeleteObject hregion
n = 8
With aLine
    dx = .X2 - .X1
    dy = .Y2 - .Y1
End With
If dx <> 0 Then
   sida = Atn(dy / dx)
Else
   sida = PI / 2
End If
With aLine
  pt(0).X = CLng(.X2 + n * Sin(sida))
  pt(0).Y = CLng(.Y2 + n * Cos(sida))
  pt(1).X = CLng(.X2 - n * Sin(sida))
  pt(1).Y = CLng(.Y2 - n * Cos(sida))
  pt(2).X = CLng(.X1 - n * Sin(sida))
  pt(2).Y = CLng(.Y1 - n * Cos(sida))
  pt(3).X = CLng(.X1 + n * Sin(sida))
  pt(3).Y = CLng(.Y1 + n * Cos(sida))
End With
hregion = CreatePolygonRgn(pt(0), 4, 1)
aLine.Tag = Str(hregion) '将hRegion记录在line.Tag
End Sub
'设定被选取的 line物件两个端点的hRegion与画上两个方框
Private Sub SetSelect()
      With aLine
	Call Rectangle(Me.hdc, .X1 - 3, .Y1 - 3, .X1 + 3, .Y1 + 3)
	Call Rectangle(Me.hdc, .X2 - 3, .Y2 - 3, .X2 + 3, .Y2 + 3)
	DeleteObject hreg1
	DeleteObject hreg2
	hreg1 = CreateRectRgn(.X1 - 3, .Y1 - 3, .X1 + 3, .Y1 + 3)
	hreg2 = CreateRectRgn(.X2 - 3, .Y2 - 3, .X2 + 3, .Y2 + 3)
	lp1.X = .X1
	lp1.Y = .Y1
	lp2.X = .X2
	lp2.Y = .Y2
      End With

End Sub
Private Sub MoveLine(ByVal X As Single, ByVal Y As Single)
   Dim dx As Long, dy As Long
   If NotRefresh Then
      Me.Refresh '去除画上的两个小方框
      NotRefresh = False
   End If
   dx = X - oldPoint.X
   dy = Y - oldPoint.Y
   If inReg1 Then 'in hreg1 则(x2, y2)不动，只改(x1, y1)
      With aLine
	.X1 = X
	.Y1 = Y
      End With
   Else
     If inReg2 Then 'in hreg2 则(x1, y1)不动，只改(x2, y2)
	With aLine
	  .X2 = X
	  .Y2 = Y
	End With
     Else   '不在hreg1, hreg2中，所以是整条线移动
	With aLine
	  .X1 = lp1.X + dx
	  .Y1 = lp1.Y + dy
	  .X2 = lp2.X + dx
	  .Y2 = lp2.Y + dy
	End With
     End If
   End If
End Sub