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

klj123 2008-02-20 05:22:32
用过“家居方圆”软件的人都知道，用该软件画一条线段后，右键点击该线段，就可选择“删除”该线段，请问高手们，用VB能实现这样的功能吗？代码如何写，请赐教！！！！！！
...全文
274 13 打赏 收藏 转发到动态 举报
AI 作业
写回复
用AI写文章
13 条回复
切换为时间正序
请发表友善的回复…
发表回复
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
  • 打赏
  • 举报
 回复
当然能了。
嗷嗷叫的老马 2008-02-20
  • 打赏
  • 举报
 回复
把每个单体图形作为对象来选择就行了.
VB串口通信源码210个
074、vb实现串口通信 文件传送系统，用vb以及mscomm控件实现 075、VB实现串口通信，发送命令从而接收相应数据 076、VB使用mscom控件实现PC机与单片机串口通信 077、VB通过COM串口读取条形码设备 078、VB通过串口控制...
VB 实现 将C++头文件 转换为VB模块 源程序
这个小程序很有用哦，使用VB语言编写，功能是实现将C++头文件转换为VB模块源程序，这样在以后你碰到VC++中那些想用的功能模块，你就可以转换为VB同功能的模块源码，有意思吧？你只需引入想要的C++模块源程序，程序为...
VB网络编程实例
◆ 88.htm 用VB创建自己的通信程序 ◆ 89.htm 用VB构建Internet的应用[微软提供] ◆ 90.htm 用VB开发标准CGI程序 ◆ 91.htm 用VB实现客户——服务器（TCP IP）编程实例 ◆ 92.htm 用VB实现...
VB for Android12.12
开发者可以利用VB的事件驱动编程模型，轻松实现用户界面的交互，同时，VB的丰富的类库也能为Android应用的功能扩展提供便利。 VB for Android的文件名列表中提到的"VB4AV12.11"可能是该软件的一个早期版本或者相关...
用VB播放Gif动画
如果能用VB播放GIF动画会使程序变得非常美观。 那么我们如何不借助第三方控件，用VB播放Gif动画呢？本资源包含的源程序代码将为您解答。 本资源压缩包内包含实现此功能的所有代码（不含第三方控件），简单...
VB基础类

7,785

社区成员

197,585

社区内容

发帖
与我相关
我的任务
社区描述
VB 基础类
社区管理员
  • VB基础类社区
加入社区
  • 近7日
  • 近30日
  • 至今

加载中

查看更多榜单
社区公告
暂无公告

试试用AI创作助手写篇文章吧

+ 用AI写文章