图形化界面举例

代码：

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

代码片段：

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

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

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

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

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