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

xyy_82216 发表于 2006-5-12 23:58:00

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

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

xyy_82216 发表于 2006-5-13 00:14:00

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 发表于 2006-5-13 00:16:00

' '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 发表于 2006-5-13 08:41:00

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

xyy_82216 发表于 2006-5-13 13:25:00

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

页: [1]

明经CAD社区's Archiver

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