图形化界面举例
1.
代码：
Private Sub cmdCancel_Click() Unload Me End Sub Private Sub cmdInsert_Click() If cmbLevels.Text = "" Then MsgBox "Please select a level" Exit Sub End If If cmbCells.Text = "" Then MsgBox "Please select a cell" Exit Sub End If Dim InsPt As Point3d Dim CellElem As CellElement InsPt.X = CDbl(txtX.Text) InsPt.Y = CDbl(txtY.Text) InsPt.Z = CDbl(txtZ.Text) Set CellElem = CreateCellElement3(cmbCells.Text, InsPt, True) CellElem.Level = ActiveDesignFile.Levels(cmbLevels.Text) ActiveModelReference.AddElement CellElem End Sub Private Sub cmdPick_Click() Dim MyMsg As CadInputMessage Dim MyQue As CadInputQueue Dim SelPt As Point3d Dim CellElem As CellElement On Error GoTo errhnd Set MyQue = Application.CadInputQueue Do Set MyMsg = MyQue.GetInput Select Case MyMsg.InputType Case msdCadInputTypeDataPoint SelPt = MyMsg.Point txtX.Text = SelPt.X txtY.Text = SelPt.Y txtZ.Text = SelPt.Z If cmbLevels.Text <> "" And cmbCells.Text <> "" Then Set CellElem = CreateCellElement3(cmbCells.Text, SelPt, True) CellElem.Level = ActiveDesignFile.Levels(cmbLevels.Text) ActiveModelReference.AddElement CellElem End If Exit Do Case Else Exit Do End Select Loop Exit Sub errhnd: Err.Clear End Sub Private Sub UserForm_Initialize() frmCellInsection.Show vbModeless Dim myLevel As Level Dim MyCellEnum As CellInformationEnumerator Dim myCell As CellInformation For Each myLevel In ActiveDesignFile.Levels cmbLevels.AddItem myLevel.Name Next Set MyCellEnum = Application.GetCellInformationEnumerator(True, True) While MyCellEnum.MoveNext Set myCell = MyCellEnum.Current cmbCells.AddItem myCell.Name Wend End Sub Private Sub txtX_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) Select Case KeyAscii Case Asc("0") To Asc("9") Case Asc(".") If InStr(1, txtX.Text, ".") > 0 Then KeyAscii = 0 End If Case Else KeyAscii = 0 End Select End Sub Private Sub txtY_Change() Select Case KeyAscii Case Asc("0") To Asc("9") Case Asc(".") If InStr(1, txtY.Text, ".") > 0 Then KeyAscii = 0 End If Case Else KeyAscii = 0 End Select End Sub Private Sub txtZ_Change() Select Case KeyAscii Case Asc("0") To Asc("9") Case Asc(".") If InStr(1, txtZ.Text, ".") > 0 Then KeyAscii = 0 End If Case Else KeyAscii = 0 End Select End Sub
2.
代码片段：
Dim WithEvents MyApp As MicroStationDGN.Application Private Sub UserForm_Initialize() Set MyApp = Application End Sub Private Sub MyApp_OnDesignFileOpened(ByVal DesignFileName As String) lstOpened.AddItem DesignFileName End Sub Private Sub MyApp_OnDesignFileClosed(ByVal DesignFileName As String) lstClosed.AddItem DesignFileName End Sub Sub ShowEvents() frmEvents.Show vbModeless End Sub
3.
Private Sub btnCancel_Click() Unload fromPointList End Sub Private Sub btnPlotPoints_Click() Dim TextIns As Point3d Dim Textval As String Dim I As Long Dim PT As TextElement Dim RotMat As Matrix3d For I = 1 To lstPoints.ListCount TextIns.X = lstPoints.List(I - 1, 0) TextIns.Y = lstPoints.List(I - 1, 1) TextIns.Z = lstPoints.List(I - 1, 2) Set PT = Application.CreateTextElement1(Nothing, lstPoints.List(I - 1, 3), TextIns, RotMat) ActiveModelReference.AddElement PT Next I End Sub Private Sub btnRead_Click() Dim PointText As String Dim PointSplit As Variant Dim FFile As Long FFile = FreeFile Open txtPointFile.Text For Input As #FFile While EOF(FFile) = False Line Input #FFile, PointText If PointText <> "" Then PointSplit = Split(PointText, ",") lstPoints.AddItem PointSplit(0) lstPoints.List(lstPoints.ListCount - 1, 1) = PointSplit(1) lstPoints.List(lstPoints.ListCount - 1, 2) = PointSplit(2) lstPoints.List(lstPoints.ListCount - 1, 3) = PointSplit(3) End If Wend End Sub Private Sub btnRemove_Click() Dim I As Long For I = lstPoints.ListCount To 1 Step -1 If lstPoints.Selected(I - 1) Then lstPoints.RemoveItem I - 1 End If Next I End Sub Sub DoPointListReader() frmPointList.Show End Sub
4.
Sub PrintHeader(HeaderIn As String, FileNum As Long, Optional Columns As Long = 1) If optASCII.Value = True Then Print #FileNum, "[" & HeaderIn & "]" ElseIf optHTML.Value = True Then Print #FileNum, "<table width=660>" Print #FileNum, "<tr><td colspan=" & Columns & " align=center><b>" & HeaderIn & "</td></tr>" End If End Sub Sub PrintLine(LineIn As String, FileNum As Long) If optASCII.Value = True Then Print #FileNum, LineIn ElseIf optHTML.Value = True Then Dim XSplit As Variant Dim I As Long XSplit = Split(LintIn, vbTab) Print #FileNum, "<tr>" For I = LBound(XSplit) To UBound(XSplit) Print #FileNum, vbTab & "<td>" & XSplit(I) & "</td>" Next I Print #FileNum, "</tr>" End If End Sub Sub PrintFooter(FileNum As Long) If optHTML.Value = True Then Print #FileNum, "</table>" & vbCrLf End If End Sub Sub DoWriteFile() frmWriteDgnSettings.Show End Sub Private Sub cmdCancel_Click() Unload frmWriteDgnSettings End Sub Private Sub cmdOK_Click() Dim myFile As String Dim FFile As Long Dim myLevel As Level Dim myLStyle As LineStyle Dim myTStyle As TextStyle Dim MyView As View FFile = FreeFile If optASCII.Value = True Then myFile = "c:output.txt" ElseIf optHTML.Value = True Then myFile = "c:output.html" End If Open myFile For Append As #FFile PrintHeader "FILE NAME", FFile, 1 PrintLine ActiveDesignFile.FullName, FFile PrintFooter FFile If chkLevels.Value = True Then PrintHeader "LEVELS", FFile, 3 For Each myLevel In ActiveDesignFile.Levels PrintLine myLevel.Name & vbTab & myLevel.Description & vbTab & myLevel.ElementColor, FFile Next PrintFooter FFile End If If chkLineStyles.Value = True Then PrintHeader "LINE STYLES", FFile, 2 For Each myLStyle In ActiveDesignFile.LineStyles PrintLine myLStyle.Name & vbTab & myLStyle.Number, FFile Next PrintFooter FFile End If If chkTextStyles.Value = True Then PrintHeader "TEXT STYLES", FFile, 3 For Each myTStyle In ActiveDesignFile.TextStyles PrintLine myTStyle.Name & vbTab & myTStyle.Color & vbTab & myTStyle.BackgroundFillColor, FFile Next PrintFooter FFile End If If chkViews.Value = True Then PrintHeader "VIEWS", FFile, 5 For Each MyView In ActiveDesignFile.Views PrintLine MyView.Origin.X & vbTab & MyView.Origin.Y & vbTab & MyView.Origin.Z & vbTab & MyView.CameraAngle & vbTab & MyView.CameraFocalLength, FFile Next PrintFooter FFile End If If chkAuthor.Value = True Then PrintHeader "Author", FFile PrintLine ActiveDesignFile.Author, FFile PrintFooter FFile End If If chkSubject.Value = True Then PrintHeader "Subject", FFile PrintLine ActiveDesignFile.Subject, FFile PrintFooter FFile End If If chkTitle.Value = True Then PrintHeader "Title", FFile PrintLine ActiveDesignFile.Title, FFile PrintFooter FFile End If Close #FFile End Sub
5.
Private Sub UserForm_Initialize() Dim ViewCen As Point3d Dim MyView As View For Each MyView In ActiveDesignFile.Views cmbViews.AddItem MyView.Index Next cmbViews.ListIndex = 0 ViewCen = ActiveDesignFile.Views(1).Center ScrX.Value = ViewCen.X scrY.Value = ViewCen.Y End Sub Sub SetZoom(ZoomValue As Long, OldZoomValue As Long) ActiveDesignFile.Views(cmbViews.Text).Zoom 1 + (ZoomValue - OldZoomValue) / 100 ActiveDesignFile.Views(cmbViews.Text).Redraw End Sub Sub SetPan(XPan As Long, YPan As Long) Dim ViewOrigin As Point3d ViewOrigin.X = XPan ViewOrigin.Y = YPan ViewOrigin.Z = 0 ActiveDesignFile.Views(cmbViews.Text).Center = ViewOrigin ActiveDesignFile.Views(cmbViews.Text).Redraw End Sub Private Sub scrZoom_Change() SetZoom ScrZoom.Value, ScrZoom.Tag ScrZoom.Tag = ScrZoom.Value End Sub Private Sub scrZoom_Scroll() SetZoom ScrZoom.Value, ScrZoom.Tag ScrZoom.Tag = ScrZoom.Value End Sub Private Sub scrX_Change() SetPan ScrX.Value, scrY.Value End Sub Private Sub scrX_Scroll() SetPan ScrX.Value, scrY.Value End Sub Private Sub scrY_Change() SetPan ScrX.Value, scrY.Value End Sub Private Sub scrY_Scroll() SetPan ScrX.Value, scrY.Value End Sub
6.
Dim Text As String Dim Num As Integer Private Sub Check() If Num = 0 Then Text = TextBox1.Text End If End Sub Private Sub CommandButton1_Click() Check TextBox1.Text = UCase(TextBox1.Text) Num = Num + 1 Text = LCase(TextBox1.Text) End Sub Private Sub CommandButton2_Click() Check TextBox1.Text = Text End Sub Private Sub CommandButton3_Click() MsgBox "小写字母转为大写字母" End Sub