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