请问用VB能实现这样的功能吗?

klj123 2008-02-20 05:22:32
用过“家居方圆”软件的人都知道,用该软件画一条线段后,右键点击该线段,就可选择“删除”该线段,请问高手们,用VB能实现这样的功能吗?代码如何写,请赐教!!!!!!
...全文
208 点赞 收藏 13
写回复
13 条回复
切换为时间正序
当前发帖距今超过3年,不再开放新的回复
发表回复
klj123 2008-02-29
感谢yidie朋友,问题终于得到解决了!!!!!
回复
yidie 2008-02-28
窗体上再添加一按钮及一弹出菜单(带删除子项),完整的代码如下,在XP,VB6下通过测试.

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 isDrawline As Boolean '指示是否画线
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 Const PI As Double = 3.1415926535

Private Sub chkDrawLine_Click() '选中 CheckBox 画线
isDrawline = Not isDrawline
End Sub

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

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
Me.Caption = hRegion5
If i <> 0 Then
oldPoint.X = X
oldPoint.Y = Y
Call SetSelect
haveSel = True
Else
haveSel = False
If isDrawline Then
lp1.X = X
lp1.Y = Y
End If
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
If Button = 2 And haveSel Then '右键弹出菜单
PopupMenu pMenu
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
If isDrawline Then
'在窗体上画直线
Line (lp1.X, lp1.Y)-(lp2.X, lp2.Y), BackColor
'擦去上次画的直线
Line (lp1.X, lp1.Y)-(X, Y), vbBlack
lp2.X = X
lp2.Y = 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
If isDrawline Then
chkDrawLine.Value = 0
'将所画的直线转换成line控件
Set aLine = Controls.Add("VB.Line", "line" & (Controls.Count + 1))
aLine.X1 = lp1.X
aLine.Y1 = lp1.Y
aLine.X2 = X
aLine.Y2 = Y
aLine.Visible = True
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
'点击弹出菜单中的删除子项
Private Sub mnuRemove_Click()
Controls.Remove aLine
Me.Refresh
haveSel = False
Set aLine = Nothing
End Sub
'点击按钮直接删除
Private Sub cmdDelete_Click()
If haveSel Then
Controls.Remove aLine
Me.Refresh
haveSel = False
Set aLine = Nothing
End If
End Sub
回复
yidie 2008-02-28
选中chcekbox,按下左键不放,在窗体上拖动,再释放鼠标就在窗体上画了一条线;
点击所画的线,再按下鼠标拖动至新位置释放,则实现线的移动。
我都在XP下测试成功了。
回复
klj123 2008-02-27
8楼朋友提供的代码无法在窗体上画线,问题出在哪儿呢??
回复
klj123 2008-02-27
我试了“Controls.Remove”方法,提示实时错误“729”,请再给出这个方法代码,马上结贴送分!!!!1
回复
yidie 2008-02-27
新建工程,在窗体中加入一checkbox,命名为chkDrawLine,写入以下代码。可以画线,画出来的线条用controls.add动态添加,线条可以选中移动旋转。你要删除的话执行Controls.Remove方法即可。

'窗体代码
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 isDrawline As Boolean '指示是否画线
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 Const PI As Double = 3.1415926535

Private Sub chkDrawLine_Click() '选中 CheckBox 画线
isDrawline = Not isDrawline
End Sub

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

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
Me.Caption = hRegion5
If i <> 0 Then
oldPoint.X = X
oldPoint.Y = Y
Call SetSelect
haveSel = True
Else
haveSel = False
If isDrawline Then
lp1.X = X
lp1.Y = Y
End If
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
If isDrawline Then
'在窗体上画直线
Line (lp1.X, lp1.Y)-(lp2.X, lp2.Y), BackColor
'擦去上次画的直线
Line (lp1.X, lp1.Y)-(X, Y), vbBlack
lp2.X = X
lp2.Y = 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
If isDrawline Then
chkDrawLine.Value = 0
'将所画的直线转换成line控件
Set aLine = Controls.Add("VB.Line", "line" & (Controls.Count + 1))
aLine.X1 = lp1.X
aLine.Y1 = lp1.Y
aLine.X2 = X
aLine.Y2 = Y
aLine.Visible = True
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
回复
qiu5208 2008-02-26
很简单啊。
回复
vbscape 2008-02-26
画线段是一回事,右击删除是另一回事,两个之间没什么关系。你对那个感兴趣呢?VB画图是吃力不讨好的事,但也应该能找到源代码。右击删除是鼠标事件,这个不需要代码示例吧。
回复
klj123 2008-02-25
怎么没人赐教啊???????
回复
meilidexue 2008-02-22
很简单了!
回复
klj123 2008-02-22
能提供一个代码示例吗?马上结贴送分哟!!!!
回复
vansoft 2008-02-21
当然能了。
回复
把每个单体图形作为对象来选择就行了.
回复
相关推荐
发帖
VB基础类
创建于2007-09-28

7489

社区成员

VB 基础类
申请成为版主
帖子事件
创建了帖子
2008-02-20 05:22
社区公告
暂无公告