VBA 操作数字

第8章 操作数字

加、减、乘、除、平方与指数（^2 或者^n）、平方根Sqr、正弦Sin、余弦Cos、正切Tan、反正切Atn、绝对值Abs

转换为整型数、长整型数、双精度型数和值

Cint当双精度型数向整型数转换时，CInt通过园整数字得到一个整型数

CLng与CInt相比：当所提供的值较大时使用CLng

Fix函数只是简单地甩掉数字的小数部分，它不做任何园整。Fix能够操作整型数和长整型数

CDbl函数可将提供的参数转换为一个双精度型数

Val函数能给出参数中的数字值。Val返回所有的数字字符直到它遇到一个非数字字符为止

IsNumeric返回一个布尔值（True 或 False) 它考察其参数并确定参数是否为数字

Round函数能够让我们指定小数点后保留的位数

Mod求余 5 Mod 2 = 1

Sgn求数的正负号。如果所给值是负数则返回-1，零返回0，正数返回1

Rnd与Randomize生成随机数

Double 的类型声明字符是数字符号 (#)。

Sub TestRnd()

Dim I As Long

Dim Lower As Long

Dim Higher As Long

Dim PointCen( To ) As Point3d

Dim PointElem As PointStringElement

Dim Num As Double

Lower = 

Higher = 

Num = 

Randomize

For I =  To 

PointCen().X = Round((Higher - Lower + ) * Rnd(), )

PointCen().Y = Round((Higher - Lower + ) * Rnd(), )

PointCen().X = PointCen().X

PointCen().Y = PointCen().Y

Set PointElem = Application.CreatePointStringElement1(Nothing, PointCen, True)

ActiveModelReference.AddElement PointElem

If Sqr((PointCen().X - ) ^  + (PointCen().Y - ) ^ ) <  Then

Num = Num + 

End If

Next I

Dim MyCir As EllipseElement

Dim CenPt As Point3d

Dim RotMatrix As Matrix3d

CenPt.X = 

CenPt.Y = 

CenPt.Z = 

Set MyCir = Application.CreateEllipseElement2(Nothing, CenPt, , , RotMatrix)

Application.ActiveModelReference.AddElement MyCir

Set MyCir = Application.CreateEllipseElement2(Nothing, CenPt, Sqr(), Sqr(), RotMatrix)

Application.ActiveModelReference.AddElement MyCir

MsgBox Num / 

MsgBox Atn()

Sub TestMessageBox2()

Dim Mes As VbMsgBoxResult

Mes = MsgBox("Unable to open file.", vbAbortRetryIgnore)

Mes = MsgBox("Format Hard Drive?", vbOKCancel)

Mes = MsgBox("New Level Added.", vbOKOnly)

Mes = MsgBox("Not Connected to Internet.", vbRetryCancel)

Mes = MsgBox("Do you want to continue?", vbYesNo)

Mes = MsgBox("Continue Reading File?", vbYesNoCancel)

Select Case Mes

Case VbMsgBoxResult.vbAbort

'add codes

Case VbMsgBoxResult.vbCancel

'add codes

Case VbMsgBoxResult.vbIgnore

'add codes

Case VbMsgBoxResult.vbNo

'add codes

Case VbMsgBoxResult.vbOK

'add codes

Case VbMsgBoxResult.vbRetry

'add codes

Case VbMsgBoxResult.vbYes

'add codes

End Select

End Sub

Sub TestMessageBox3()

Dim Mes As VbMsgBoxResult

Mes = MsgBox("Unable to open file.", vbAbortRetryIgnore + vbCritical)

Mes = MsgBox("Format Hard Drive?", vbOKCancel + vbExclamation)

Mes = MsgBox("New Level Added.", vbOKOnly + vbInformation)

Mes = MsgBox("Do you want to continue?", vbYesNo + vbQuestion)

End Sub

Sub TestMessageBox4()

MsgBox "Testing Title", vbCritical, "Title Goes Here"

MsgBox "Testing Title", , "Title Goes Here"

End Sub

标题参数显示在消息框的顶部，它是第三个参数，消息框仅有一个参数是必须的，那就是提示参数。要显示提示、标题以及缺省按钮，在提示参数后方一个逗号、一个空格、另一个逗号，然后是标题。若要跳过一个可选参数，就让这个参数空着并用逗号指明你要提供下一个参数了。

输入框

Sub TestInputBox2()

Dim InpRet As String

InpRet = InputBox("Enter Level Name:", "Level Creator", "Striping", , )

Debug.Print "User entered" & InpRet

End Sub

Now函数给出当前的系统日期和时间。

Sub TestNow()

MsgBox Now

End Sub

DateAdd函数能够展望未来或回忆过去

Sub TestDateAdd()

Dim NowDate As Date

NowDate = Now

Debug.Print NowDate & vbTab & DateAdd("d", , NowDate) '日

Debug.Print NowDate & vbTab & DateAdd("h", , NowDate) '时

Debug.Print NowDate & vbTab & DateAdd("n", , NowDate) '分

Debug.Print NowDate & vbTab & DateAdd("s", , NowDate) '秒

Debug.Print NowDate & vbTab & DateAdd("m", , NowDate) '月

Debug.Print NowDate & vbTab & DateAdd("w", , NowDate) '周

Debug.Print NowDate & vbTab & DateAdd("yyyy", , NowDate) '年

Debug.Print NowDate & vbTab & DateAdd("q", , NowDate) '季

End Sub

DateDiff计算两个日期的时间差

Sub TestDateDiff()

Dim NowDate As Date

NowDate = Now

Debug.Print "Days" & vbTab & DateDiff("d", NowDate, "1/1/3000")

Debug.Print "Hours" & vbTab & DateDiff("h", NowDate, "1/1/3000")

Debug.Print "Minutes" & vbTab & DateDiff("n", NowDate, "1/1/3000")

Debug.Print "Seconds" & vbTab & DateDiff("s", NowDate, "1/1/3000")

Debug.Print "Months" & vbTab & DateDiff("m", NowDate, "1/1/3000")

Debug.Print "Weeks" & vbTab & DateDiff("w", NowDate, "1/1/3000")

Debug.Print "Years" & vbTab & DateDiff("yyyy", NowDate, "1/1/3000")

Debug.Print "Quarters" & vbTab & DateDiff("q", NowDate, "1/1/3000")

End Sub

Timer 告诉我们自午夜开始所经历的秒数

Sub TestTimer()

MsgBox Timer

End Sub

FileDataTime可以给出文件最后修改的日期/时间

FileLen函数可以告知给定文件的大小 以字节为单位

Sub TestFileDateTime()

Dim exeDate As Date

exeDate = FileDateTime("C:\Program Files (x86)\Bentley\MicroStation V8i (SELECTseries)\MicroStation\ustation.exe")

MsgBox "MicroStation Date/Time: " & exeDate

End Sub

Sub TestFileLen()

Dim exeSize As Long

exeSize = FileLen("C:\Program Files (x86)\Bentley\MicroStation V8i (SELECTseries)\MicroStation\ustation.exe")

MsgBox "MicroStation Size: " & exeSize

End Sub

MkDir建立新目录

RmDir函数从文件系统中删除一个目录。被删除的目录必须是空的，否则会产生一个错误。

Sub TestMkDir()

MkDir "c:\Program Files (x86)\Bentley\MicroStation V8i (SELECTseries)\SourceCode"

End Sub

Sub TestRmDir()

RmDir "c:\Program Files (x86)\Bentley\MicroStation V8i (SELECTseries)\SourceCode"

End Sub

Dir函数能够查找文件和文件夹(目录)

Kill 该函数的结果是永久性的。被“杀掉”的文件没有送到回收站，它们被完全删除。使用时要特别小心！

Beep函数使电脑发出哔哔声，在代码运行过程中它能给用户一个快速的声音提示。

SaveSetting使用Windows注册表能保存用户在软件中的设置。微软已经为VBA程序建立了一个注册表路径，我们很容易地写、编辑和删除这个路径

GetSetting函数能够取得注册表中的设置

Sub TestSaveSetting()

SaveSetting "Learning MicroStation VBA", "Chapter 9", "SaveSetting", "It Works"

End Sub

Sub TestGetSetting()

Dim RegSetting As String

RegSetting = GetSetting("Learning MicroStation VBA", "Chpater 9", "SaveSetting")

Debug.Print "The Key SaveSetting value is "" " & RegSetting & """"

End Sub

DeleteSetting能够删除注册表中的设置

Sub TestDeleteSetting()

DeleteSetting "Learning Microstation VBA", "Chapter 9", "SaveSetting"

End Sub

Sub TestDeleteSetting2()

DeleteSetting "Learning Microstation VBA", "Chapter 9"

End Sub

Sub TestDeleteSetting3()

DeleteSetting "Learning MicroStation VBA"

End Sub

GetAllSettings函数从注册表中取得指定应用下的所有键，并把它们放入一个多维数组中

读写ASCII文件

Sub TestWriteASCIIA()

Open "C:\output.txt" For Output As #

Print #, "First line"

Print #, "Second line"

Close #

End Sub

Sub TestWriteASCIIB()

Open "C:\output.txt" For Output As #

Write #, "First line"

Write #, "Second line"

Close #

End Sub

Sub TestWriteASCIIC()

Open "C:\output.txt" For Append As #

Print #, "Another line 1."

Print #, "Another line 2."

Close #

End Sub

Sub TestWriteASCIID()

Dim FFileA As Long

Dim FFileB As Long

FFileA = FFile

Open "C:\outputa.txt" For Append As #FFileA

Print #FFileA, "Another line 1."

Print #FFileA, "Another line 2."

FFileB = FreeFile

Open "C:outputb.txt" For Append As FFileB

Print #FFileA, "Another line 3."

Print #FFileB, "Another line 3."

Print #FFileA, "Another line 4."

Print #FFileB, "Another line 4."

Close #FFileB

Close #FFileA

End Sub

Sub ReadASCIIA()

Dim FFile As Long

Dim TextLine As String

FFile = FreeFile

Open "C:\output.txt" For Input As #FFile

While EOF(FFile) = False

Line Input #FFile, TextLine

Debug.Print TextLine

Wend

Close #FFile

End Sub

控制代码的执行

For…Next语句

P116

While …Wend

Do…Loop 可以使用Exit Do在任何时候退出Do…Loop语句

For Each…Next

If …Then还可以加上Else语句进行其他情况的处理，最后要加上End If

Select Case 相当于多个If语句

错误处理 On Error GoTo errhnd

On ErrorResume Next告诉VBA完全忽略错误并移动到下一行继续执行，从而代替去捕捉错误

errhand:

Select Case Err.number

Case 13 '类型不匹配

Err.Clear

'Resume Next

'Resume

End Select

本章回顾

VBA内置了很多过程和函数。使用内置的过程或者函数可以简化工作

第十章 可视界面

Sub PrintHeader(HeaderIn As String, FileNum As Long, Optional Columns As Long = )

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 Output As #FFile

PrintHeader "FILE NAME", FFile, 

PrintLine ActiveDesignFile.FullName, FFile

PrintFooter FFile

If chkLevels.Value = True Then

PrintHeader "LEVELS", FFile, 

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, 

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, 

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, 

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 "Authr", 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