zoukankan      html  css  js  c++  java

  • 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(0 To 1) As Point3d

Dim PointElem As PointStringElement

Dim Num As Double

Lower = 0

Higher = 1

Num = 0

Randomize

For I = 1 To 60000

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

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

PointCen(1).X = PointCen(0).X

PointCen(1).Y = PointCen(0).Y

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

ActiveModelReference.AddElement PointElem

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

Num = Num + 1

End If

Next I

Dim MyCir As EllipseElement

Dim CenPt As Point3d

Dim RotMatrix As Matrix3d

CenPt.X = 1

CenPt.Y = 1

CenPt.Z = 0

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

Application.ActiveModelReference.AddElement MyCir

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

Application.ActiveModelReference.AddElement MyCir

MsgBox Num / 60000

MsgBox Atn(1)
    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
    


     
    

    

    clip_image002
    

    clip_image003
    

    clip_image004
    

    clip_image005
    

    clip_image006
    

    clip_image007
    

    

    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
    

    


    clip_image008
    

    clip_image009
    

    clip_image010
    

    clip_image011
    

    

    Sub TestMessageBox4()

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

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

End Sub
    

    


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

    clip_image012
    

    clip_image013
    

    输入框
    

    

    Sub TestInputBox2()

Dim InpRet As String

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

Debug.Print "User entered" & InpRet

End Sub
    

    


    clip_image014
    


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

    

    Sub TestNow()

MsgBox Now

End Sub
    

    


    clip_image016
    

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

    

    Sub TestDateAdd()

Dim NowDate As Date

NowDate = Now

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

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

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

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

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

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

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

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

End Sub
    

    


    clip_image017
    

    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
    

    


    clip_image018
    

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

    

    Sub TestTimer()

MsgBox Timer

End Sub
    

    


    clip_image019
    

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

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

    

    Sub TestFileDateTime()

Dim exeDate As Date

exeDate = FileDateTime("C:Program Files (x86)BentleyMicroStation V8i (SELECTseries)MicroStationustation.exe")

MsgBox "MicroStation Date/Time: " & exeDate

End Sub

Sub TestFileLen()

Dim exeSize As Long

exeSize = FileLen("C:Program Files (x86)BentleyMicroStation V8i (SELECTseries)MicroStationustation.exe")

MsgBox "MicroStation Size: " & exeSize

End Sub
    

    


    clip_image020
    

    clip_image021
    

    MkDir建立新目录
    

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

    

    Sub TestMkDir()

MkDir "c:Program Files (x86)BentleyMicroStation V8i (SELECTseries)SourceCode"

End Sub

Sub TestRmDir()

RmDir "c:Program Files (x86)BentleyMicroStation 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 #1

Print #1, "First line"

Print #1, "Second line"

Close #1

End Sub

Sub TestWriteASCIIB()

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

Write #1, "First line"

Write #1, "Second line"

Close #1

End Sub

Sub TestWriteASCIIC()

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

Print #1, "Another line 1."

Print #1, "Another line 2."

Close #1

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 = 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 Output 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 "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
    

    


    
    
                
    
                
              
    • 
              
    
              
  • 

                相关阅读:
    
                
                  最小生成树算法
                    
    并查集
                    
    背包问题
                    
    木桶排序
                    
    STL之vector
                    
    STL中的queue用法与stack用法对比
                    
    快速幂求模
                    
    归并排序+典型例题（逆序对）
                    
    负进制转换
                    
    冒泡排序
                    
                        
              
    • 
              
    
              
  • 
                原文地址：https://www.cnblogs.com/zpfbuaa/p/5748903.html
              
    • 

            

          



          
          

            

            

          

        

      

      



      

      

        

          Copyright © 2011-2022 走看看