急急急~~！怎么样点击图形，弹出对话框窗体来输入参数！~~~

xyy_82216

我通过输入参数的窗体输入参数，然后画了一个图形，画完图，我怎么在次点击图的时候在次让它弹出参数窗体，然后我可以从新输入参数，来从新画图，或者改变图的大小？？

 

xyy_82216

Option Explicit

 

'定义图形的12条边界线
Global lineobject(0 To 11) As AcadLine
'定义图形面域
Global regionobject As Variant
 '定义图形拉伸后的实体
Global solidobject As Acad3DSolid

'定义图形的宽度、高度和厚度等参数
Global beamwidth As Double
Global beamheight As Double
Global beamwebthickness As Double
Global solidlength As Double
Global beammi As Double
Global beamsectmod As Double
Global beamexists As Boolean
Global buffblock As AcadBlock

Public Sub createibeam(width As Double, height As Double, webthickness As Double, solcdlength As Double)

   definebeam width, height, webthickness
  
   regionobject = buffblock.AddRegion(lineobject)
   Set solidobject = ThisDrawing.ModelSpace.AddExtrudedSolid(regionobject(0), solidlength, 0)
   beamexists = True
   Dim vportobj As Object
   Set vportobj = ThisDrawing.Viewports.Add("IBEAMVIEWPORT")
   ThisDrawing.ActiveViewport = vportobj
  
  
   Dim newdirection(0 To 2) As Double
       newdirection(0) = 1#
       newdirection(1) = -1#
       newdirection(2) = 1#
    vportobj.Direction = newdirection
    ThisDrawing.ActiveViewport = vportobj
   
  
End Sub

Public Function checkrules(width As Double, height As Double, webthickness As Double) As Boolean
    Dim webheight As Double
   
       If (width > 0) And (height > 0) And (webthickness > 0) Then
           webheight = height - 2 * webthickness
              If webheight <= 0 Then
                  Exit Function
              End If
              If (width > webthickness) And (height > webheight) And (webthickness >= width / 6) And (webheight >= width / 4) Then
              checkrules = True
              End If
       End If
End Function

Sub IBEAMVBA()
   UserForm1.Show
End Sub
Private Sub definebeam(width As Double, height As Double, webthickness As Double)
   Dim x(0 To 11) As Double
   Dim y(0 To 11) As Double
   Dim z As Double
      z = 0
     
   Dim halfflange As Double
      halfflange = (width - webthickness) / 2
   Dim halfht As Double
      halfht = height - 2 * webthickness
     
     
     x(0) = 0
     y(0) = 0
     x(1) = x(0) + width
     y(1) = y(0)
     x(2) = x(1)
     y(2) = y(1) + webthickness
     x(3) = x(2) - halfflange
     y(3) = y(2)
     x(4) = x(3)
     y(4) = y(3) + halfht
     x(5) = x(2)
     y(5) = y(4)
     x(6) = x(5)
     y(6) = y(5) + webthickness
     x(7) = x(0)
     y(7) = y(6)
     x(8) = x(0)
     y(8) = y(5)
     x(9) = x(8) + halfflange
     y(9) = y(4)
     x(10) = x(9)
     y(10) = y(2)
     x(11) = x(0)
     y(11) = y(2)
    
  Dim inspt(0 To 2) As Double
      inspt(0) = 0
      inspt(1) = 0
      inspt(2) = 0
     
  Set buffblock = ThisDrawing.Blocks.Add(inspt, "buffblock")
  
  Dim startpoint(0 To 2) As Double
  Dim endpoint(0 To 2) As Double
  Dim i As Integer
  Dim j As Integer
  For i = 0 To 11
      startpoint(0) = x(i)
      startpoint(1) = y(i)
      startpoint(2) = 0
        j = i + 1
          If i = 11 Then
             j = 0
          End If
          endpoint(0) = x(j)
          endpoint(1) = y(j)
          endpoint(2) = 0
            If beamexists Then
               lineobject(i).startpoint = startpoint
               lineobject(i).endpoint = endpoint
            Else
               Set lineobject(i) = buffblock.AddLine(startpoint, endpoint)
            End If
   Next
End Sub

Public Sub updatabeam(width As Double, height As Double, webthickness As Double, solidlength As Double)
    definebeam width, height, webthickness
   
    regionobject(0).Erase
    regionobject = buffblock.AddRegion(lineobject)
   
    solidobject.Erase
    Set solidobject = ThisDrawing.ModelSpace.AddExtrudedSolid(regionobject(0), solidlenght, 0)
   
       ThisDrawing.ActiveViewport.ZoomExtents
       beamexists = True
      
   
End Sub

Public Function momentofinteria(width As Double, height As Double, webthickness As Double) As Double
   
     Dim webht As Double
         webht = height - 2 * webthickness
        
         momentofinteria = (width * height * height - webthickness * webht * webht * webht) / 12
End Function

Public Function sectionmodulus(width As Double, height As Double, webthickness As Double) As Double
   Dim mi As Double
  
       mi = momentofinteria(width, height, webthickness)
       sectionmodulus = (mi * 12) / (6 * height)

End Function

这是模块里的程序

xyy_82216

'
'Sub rotate_3Dbox()
'   Dim boxobj As Acad3DSolid
'   Dim length As Double
'   Dim width As Double
'   Dim height As Double
'   Dim center(0 To 2) As Double
'
'   center(0) = 5
'   center(1) = 5
'   center(2) = 0
'   length = 5
'   width = 7
'   height = 9
'
'
'   Set boxobj = ThisDrawing.ModelSpace.AddBox(center, length, width, height)
'End Sub

Option Explicit

Private Sub cmdcreatebeam_Click()

   beamwidth = Scrlwidth.Value
   beamheight = Scrlheight.Value
   beamwebthickness = Scrlthickness.Value
   solidlength = scrllength.Value
  
   If checkrules(beamwidth, beamheight, beamwebthickness) Then
      createibeam beamwidth, beamheight, beamwebthickness, solidlength
      updatamomentandsection beamwidth, beamheight, beamwebthickness
   Else
      MsgBox "sorry,the beam cannot be created with your settings.", vbExclamation
  
   
  If Not (beamexists) Then
     MsgBox "defult setting restored.", vbInformation
    
     
    Scrlwidth.Value = 650
    Scrlheight.Value = 650
    Scrlthickness.Value = 125
    scrllength.Value = 200
  End If
End If
   
End Sub

Private Sub cmdquit_Click()
    Unload Me
End Sub

Private Sub Label8_Click()

End Sub

Private Sub Scrlheight_Change()
   If beamexists = True Then
      If checkrules(beamwidth, Scrlheight.Value, beamwebthickness) Then
         beamheight = Scrlheight.Value
        
         updatabeam beamwidth, beamheight, beamwebthickness, solidlength
         updatamomentandsection beamwidth, beamheight, beamwebthickness
      Else
        Scrlheight.Value = beamheight
      End If
   End If
End Sub

Private Sub scrllength_Change()
  If beamexists Then
     solidlength = scrllength.Value
   
     updatabeam beamwidth, beamheight, beamwebthickness, solidlength
     updatamomentandsection beamwidth, beamheight, beamwebthickness
  End If
End Sub

Private Sub Scrlthickness_Change()
    If beamexists Then
       If checkrules(beamwidth, beamheight, Scrlthickness.Value) Then
          beamwebthickness = Scrlthickness.Value
         
        updatabeam beamwidth, beamheight, beamwebthickness, solidlength
        updatamomentandsection beamwidth, beamheight, beamwebthickness
       Else
         Scrlthickness.Value = beamwebthickness
       End If
    End If
End Sub

Private Sub Scrlwidth_Change()
     If beamexists Then
   
         If checkrules(Scrlwidth.Value, beamheight, beamwebthickness) Then
            beamwidth = Scrlwidth.Value
           
            
            updatabeam beamwidth, beamheight, beamwebthickness, solidlength
            updatamomentandsection beamwidth, beamheight, beamwebthickness
       Else
   
           Scrlwidth.Value = beamwidth
         End If
     End If
    
   
   
End Sub

Private Sub UserForm_Click()

End Sub

Private Sub UserForm_Initialize()
   Scrlwidth.Value = 650
   Scrlheight.Value = 650
   Scrlthickness.Value = 125
   scrllength.Value = 200
  
End Sub

 

Private Sub updatamomentandsection(beamwidth#, beamheight#, beamwebthickness#)
   beammi = momentofinteria(beamwidth, beamheight, beamwebthickness)
   beamsectmod = sectionmodulus(beamwidth, beamheight, beamwebthickness)
  
   Label8.Caption = Format(beammi, "0.0000E+00")
   Label7.Caption = Format(beamsectmod, "0.0000E+00")
End Sub

Private Sub UserForm_Terminate()
   Set solidobject = Nothing
   Dim entry As Object
  
   For Each entry In ThisDrawing.Blocks
       If entry.Name = "BUFFBLOCK" Then
            buffblock.Delete
        End If
    Next
   
    beamexists = False
End Sub

这是窗体程序，现在的问题就是想点击画的图就弹出窗体

xinghesnak

通过窗体的ObjectModified事件来做。。。

xyy_82216

ObjectModified事件?????你能说的详细点么？？我以前没有没有接触过这个时间~~~我上面发的有代码，ObjectModified事件加在哪呢？怎么加，先谢谢了~~~