全部

请问用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