您的位置:澳门新葡8455最新网站 > 澳门新葡萄京娱乐场 > X3计算封闭曲线长度和面积,Excel怎么抓取网络数

X3计算封闭曲线长度和面积,Excel怎么抓取网络数

发布时间:2019-11-06 06:43编辑:澳门新葡萄京娱乐场浏览(173)

    问题:在日常干活中会遇到,知道当中三个数据,比方姓名,在报表中输入人名后,想要自动带出网页中该姓名对应的相关数据,比如该姓名的对讲机,地址等音讯,怎么办到吗?

    用作世界最理想的矢量图形设计软件CorelDRAW X3(最新版卡塔尔国居然未有询问图形周长、面积的法力,然则作为矢量图形设计软件,查询图形几何属性是必备的,幸而有VBA,给了大家扩大CorelDRAW X3功力的无限空间,以下正是询问矢量图形几何新闻的VBA进程。若是您有Corel Designer 12,   可以在其间找到此意义,将内部的窗体,模块,类模块,导出,再到 CorelDRAW X3 VBA中,把它们导过来,运维“宏”就足以在CorelDRAW X3中运营了,若无请看上面宏代码编写进度。

    回答:

    1、运营CorelDRAW X3,新建“图形1”,按“Alt+F11”张开Visual Basic编辑器,加多如下图所示顾客窗体,名叫“frmGeometric”:图片 12、为窗体编写VBA代码,窗体代码全体之类:

    Excel抓取并询问互连网数据足以利用“获取和调换”+“查找援引函数”的职能结合来兑现。

    Option Explicit

    例:下图是百度百科“奥林匹克运动会”网页中的一个报表,大家以此为例完成抓取该表格至Excel中,而且能够通过输入第几届来询问相应的举行城市。

    Private CurUnit As Long
    Private Lang As New clsLang
    Private bPerimeter As Boolean
    Private bValidSelection As Boolean
    Private bValidArea As Boolean
    Private vDepth As Double

    图片 2

    Private vLength As Double
    Private vArea As Double

    Step1:使用“获取和调换”效用将互连网数据抓取至Excel中

    逐个点击“数据选项卡”、“新建查询”、“从其它源”、“从Web”。

    图片 3

    弹出如下窗口,手动将百度宏观“奥林匹克运动会”的网站复制粘入U奥迪Q7L栏,并点击鲜明。

    图片 4

    Excel与网页连接须求一如时期,稍等片刻后会弹出如下窗口,侧面列表中的种种Table都代表该网页中的三个报表,挨个点击预览后开采,Table3是大家所需的数码。

    图片 5

    点开下方的“加载”旁边的下拉箭头,选用“加载到”。

    图片 6

    在弹出的窗口中,在“选取想要在劳作薄中查阅此数据的法子”下抉择“表”,并点击加载。

    图片 7

    如图,网页表格中的数据已被抓取至Excel中。

    图片 8

    逐一点击“表格工具”、“设计”,将“表名称”改为奥林匹克运动会。

    图片 9

    Private WithEvents cPrecision As clsIntSpin

    Step2:使用“查找与援用”函数完结多少查询

    树立查询区域,蕴涵“届数”和“主办城市”,在届数中放肆筛选黄金年代届输入,下图输入“第08届”,在主持城市下输入vlookup函数,能够获取第08届奥林匹克运动会的掌管理城市市是巴黎,当修正届数时,对应的起头城市也随时变动。

    公式:=VLOOKUP([届数],奥运会[#全部],4,0)

    图片 10

    注意点:若网页中的数据变动较频繁,则足以安装链接网页的数据定期刷新:

    ①将鼠标定位于导入的数据区域中,切换来选项卡,点击下拉箭头→

    图片 11

    ②在弹出的对话框中,设置,比方设置为10分钟进行刷新。那样,每间距10分钟数据就能刷新叁回,时刻保障收获的多寡位最新的。

    图片 12


    style="font-weight: bold;">「精进Excel」系头条签订公约小编,关切本身,假如率性点开三篇随笔,没有你想要的文化,算本人耍流氓!

    回答:

    大家好,小编是@Excel实例录制网址长@接待私信只怕特邀本身回答Excel相关难题!


    有人在群里问手提式有线电话机号怎么批量查归属地,第风流倜傥感到是百度时而,结果还真没找到好用的,既然如此,笔者就协和写多个呢!首先找了多少个webapi,找到个非常好用的,就用vba写了个自定义函数,测验下以为依然蛮好用,速度也挺快

    图片 13

    style="font-weight: bold;">源文件下载链接请私信回复63005就可以

    运用办法:

    1.在本表中一直在A1列输入手提式有线电话机号就能够

    2.要在其余表中,alt+f11开发vbe编辑器,复制模块中代码,在您的新表中确立模块,粘贴代码就可以

    3.函数参数表明

    GetPhoneInfo(号码,参数)

    号码—即单个手机号

    参数(1,2,3,4):1-城市,2-省,3-运营商, 4-全部

    代码如下

    Dim ObjXML As Object

    Function GetPhoneInfo(number, Optional para As Byte = 1)

    '获取手机号对应的主干消息 默以为城市

    'para:1-城市,2-省,3-运营商,4,全部

    Dim s As String

    s = GetBody("" & number)

    Select Case para

    Case 1

    GetPhoneInfo = HtmlFilter(s, "City"":""", """")

    Case 2

    GetPhoneInfo = HtmlFilter(s, "Province"":""", """")

    Case 3

    GetPhoneInfo = HtmlFilter(s, "TO"":""", """")

    Case 4

    GetPhoneInfo = HtmlFilter(s, "City"":""", """") & "," & HtmlFilter(s, "Province"":""", """") & "," & HtmlFilter(s, "TO"":""", """")

    End Select

    GetPhoneInfo = Replace(GetPhoneInfo, " ", "")

    End Function

    Private Sub Test()

    Dim i&, j&, k&, arr, brr

    url = ""

    Debug.Print GetBody(url)

    End Sub

    '''若是现身乱码,UTF-8可改为GB2312

    Public Function GetBody(ByVal url$, Optional ByVal Coding$ = "utf-8")

    On Error Resume Next

    Set ObjXML = CreateObject("Microsoft.XMLHTTP")

    With ObjXML

    .Open "Get", url, False, "", ""

    '.setRequestHeader "If-Modified-Since", "0"

    '.setRequestHeader "User-Agent", _

    ".Mozilla/5.0 (Windows NT 6.1; WOW64; rv:47.0) Gecko/20100101 Firefox/47.0"

    .Send

    GetBody = .ResponseBody

    End With

    GetBody = BytesToBstr(GetBody, Coding)

    Set ObjXML = Nothing

    End Function

    Public Function BytesToBstr(strBody, CodeBase)

    Dim ObjStream

    Set ObjStream = CreateObject("Adodb.Stream")

    With ObjStream

    .Type = 1: .Mode = 3: .Open:

    .Write strBody: .Position = 0: .Type = 2: .Charset = CodeBase

    BytesToBstr = .ReadText: .Close

    End With

    Set ObjStream = Nothing

    End Function

    Public Function HtmlFilter(ByVal htmlText$, ByVal Label1$, ByVal label2$)

    '重返html字符串lable1和前天的lable2标签中的数据

    Dim pStart As Long, pStop As Long

    pStart = InStr(htmlText, Label1) + Len(Label1)

    If pStart <> 0 Then

    pStop = InStr(pStart, htmlText, label2)

    HtmlFilter = Mid(htmlText, pStart, pStop - pStart)

    End If

    End Function

    回答:

    正式的人做正规职业。

    Private Sub OnUnitChange(ByVal Unit As Long)
        Dim strLength As String
        Dim strArea As String
        Dim strVolume As String
       
        vDepth = Application.ConvertUnits(vDepth, GetAppUnits(CurUnit), GetAppUnits(Unit))
        CurUnit = Unit
        UpdateDepth
       
        strLength = GetCurUnitString()
        lblUnitLength.Caption = strLength
        lblUnitArea.Caption = strLength & GetSquare(False)
        lblUnitDepth.Caption = strLength
        lblUnitVolume.Caption = strLength & GetCube(False)
       
        UpdateValues
    End Sub

    倘使只是不常有其一职责,依然在互连网出点钱,找人做了。

    开销的钱确实比少之又少。几百元丰裕了。

    Private Sub UpdateDepth()
        Updating = Updating + 1
        txtDepth.Text = CStr(vDepth)
        Updating = Updating - 1
    End Sub

    只如果平常职务多,且有必然的根底,学习一下未必不可。

    老猫是经过VBA操作的,写叁个代码,抓取数据,也异常的低价。

    老猫正在开垦的生机勃勃款足彩软件程序救市从互连网抓取大量多少。然后剖判和瞻望足彩。

    Private Function GetCurUnitString() As String
        Dim strLength As String
        Select Case CurUnit
            Case 0
                strLength = Lang.GetString(eUnitInch)
            Case 1
                strLength = Lang.GetString(eUnitMM)
            Case 2
                strLength = Lang.GetString(eUnitCM)
            Case 3
                strLength = Lang.GetString(eUnitM)
        End Select
        GetCurUnitString = strLength
    End Function

    那是抓取的竞技列表:

    图片 14

    Private Function GetSquare(ByVal bUnicode As Boolean) As String
        Dim s As String
        s = ChrW$(178)
        If Not bUnicode And Asc(s) = 63 Then
            s = "2"
        End If
        GetSquare = s
    End Function

    那是VBA程序代码

    图片 15

    Private Function GetCube(ByVal bUnicode As Boolean) As String
        Dim s As String
        s = ChrW$(179)
        If Not bUnicode And Asc(s) = 63 Then
            s = "3"
        End If
        GetCube = s
    End Function

    那是抓取的赔率数据

    图片 16

    不问可见,假设想学是一举成功的。

    回答:

    以EXCEL二〇〇〇为例来给你验证。

    风流洒脱、首先张开EXCEL2004,在菜单栏找到“数据”然后在下拉菜单点击“导入外界数据-新建WEB查询”
    图片 17
    二、然后在开发的对话框中的地址栏中,将您要导入的网站输入进去,按下转到开关。
    图片 18
    三、在弹开的对话框中原则须要导入的区域,按下导入按键,此时,数据就被导入到EXCEL里面啦!
    图片 19末段,你的微微型机得链接网络,要不未有数量,那样导入的利润是,能够和网址上保持黄金年代致,无需实行手动更新,很实惠。

    Private Sub cArea_Click()
        UpdateControls
    End Sub

    Private Sub cboUnits_Change()
        OnUnitChange cboUnits.ListIndex
    End Sub

    Private Sub cLength_Click()
        UpdateControls
    End Sub

    Private Sub cmClose_Click()
        Unload Me
    End Sub

    Private Sub cmCopy_Click()
        Dim sData As String
        Dim oData As New DataObject

        sData = GetDataString(False)
        If sData <> "" Then
            oData.SetText sData
            oData.PutInClipboard
        End If
    End Sub

    Private Sub cmCreateText_Click()
        Const TextSize As Double = 24 ' 24 pt text
        Dim lr As Layer
        Dim sData As String
        Dim sr As ShapeRange
        Dim x As Double, y As Double, w As Double, h As Double
        sData = GetDataString(True)
        Updating = Updating + 1
        If Not ActiveShape Is Nothing And sData <> "" Then
            Set sr = ActiveSelectionRange
            ActiveShape.GetBoundingBox x, y, w, h
            x = x + w / 2
            y = y - ActiveDocument.ToUnits(TextSize, cdrPoint)
            Set lr = ActiveShape.Layer
            If lr.Editable Then Set lr = ActiveLayer
            lr.CreateArtisticText x, y, sData, cdrEnglishUS, , "Times New Roman", 24, cdrTrue, cdrTrue, , cdrLeftAlignment
            sr.CreateSelection
        End If
        Updating = Updating - 1
    End Sub

    Private Sub cmRefresh_Click()
        RefreshForm
    End Sub

    Private Sub cmReset_Click()
        vDepth = 0
        UpdateDepth
        UpdateValues
    End Sub

    Private Sub cPrecision_Change()
        UpdateValues
    End Sub

    Private Sub cVolume_Click()
        UpdateControls
    End Sub

     

    Private Sub txtDepth_Change()
        Dim s As String
       
        If Updating Then Exit Sub
       
        s = Trim$(txtDepth.Text)
        If s <> "" Then
            vDepth = Val(Replace(s, ",", "."))
        Else
            vDepth = 0
        End If
        UpdateValues
    End Sub

    Private Sub UserForm_Initialize()
        Updating = 0
        vDepth = 0
       
        Set cPrecision = New clsIntSpin
        cPrecision.Init txtPrecision, spnPrecision, 3, lblPrecision, 0, 5, 1
       
        Me.Caption = Lang.GetString(eFormCaption)
       
        grpLength.Caption = Lang.GetString(eCapPerimeter)
        cLength.Caption = Lang.GetString(eCapPerimeter) & ":"
        bPerimeter = True
       
        grpArea.Caption = Lang.GetString(eCapArea)
        cArea.Caption = Lang.GetString(eCapArea) & ":"
       
        grpVolume.Caption = Lang.GetString(eCapVolume)
        lblDepth.Caption = Lang.GetString(eCapDepth) & ":"
        cmReset.Caption = Lang.GetString(eBtnReset)
        cVolume.Caption = Lang.GetString(eCapVolume) & ":"
       
        cmCreateText.Caption = Lang.GetString(eBtnCreateText)
        cmCopy.Caption = Lang.GetString(eBtnCopy)
        cmClose.Caption = Lang.GetString(eBtnClose)
        cmRefresh.Caption = Lang.GetString(eBtnRefresh)
        lblUnits.Caption = Lang.GetString(eCapUnits) & ":"
        lblPrecision.Caption = Lang.GetString(eCapPrecision) & ":"
      
        cboUnits.Clear
        cboUnits.AddItem Lang.GetString(eStrInch)
        cboUnits.AddItem Lang.GetString(eStrMM)
        cboUnits.AddItem Lang.GetString(eStrCM)
        cboUnits.AddItem Lang.GetString(eStrM)
        cboUnits.ListIndex = IIf(Lang.IsMetric(), 1, 0)
       
        RefreshForm
        MacroRunning = True
    End Sub

    Sub RefreshForm()
        Dim nSelCount As Long
       
        bValidSelection = False
        bValidArea = False
       
        Updating = Updating + 1
       
        On Error GoTo ErrHandler
       
        If Not ActiveDocument Is Nothing Then
            nSelCount = ActiveDocument.Selection.Shapes.Count
            Select Case nSelCount
                Case 0
                    ShowStatusMessage Lang.GetString(eStrNoSelection)
                   
                Case 1
                    ProcessSelection ActiveShape
                   
                Case Else
                    ShowStatusMessage Lang.GetString(eStrGroupSelected)
            End Select
        Else
            ShowStatusMessage Lang.GetString(eStrNoSelection)
        End If
       
    ExitSub:
        UpdateControls
        Updating = Updating - 1
        Exit Sub
       
    ErrHandler:
        ShowStatusMessage Lang.GetString(eStrError) & ": " & Err.Description
        Resume ExitSub
    End Sub

    Private Sub EnableTextControl(ByVal Txt As TextBox, ByVal bState As Boolean)
        Txt.Enabled = bState
        Txt.BackColor = IIf(bState, vbWindowBackground, vbButtonFace)
    End Sub

    Private Sub UpdateControls()
        Dim bEnabled As Boolean
       
        cLength.Enabled = bValidSelection
        EnableTextControl txtLength, bValidSelection
        lblUnitLength.Enabled = bValidSelection

        cArea.Enabled = bValidArea
        EnableTextControl txtArea, bValidArea
        lblUnitArea.Enabled = bValidArea
       
        lblDepth.Enabled = bValidArea
        EnableTextControl txtDepth, bValidArea
        lblUnitDepth.Enabled = bValidArea
        cmReset.Enabled = bValidArea
        cVolume.Enabled = bValidArea
        EnableTextControl txtVolume, bValidArea
        lblUnitVolume.Enabled = bValidArea
       
        bEnabled = bValidSelection
        If bEnabled Then
            bEnabled = cLength.Value <> 0
            If bValidArea And Not bEnabled Then
                bEnabled = cArea.Value <> 0 Or cVolume.Value <> 0
            End If
        End If
        cmCreateText.Enabled = bEnabled
        cmCopy.Enabled = bEnabled
    End Sub

    Private Sub ProcessSelection(ByVal s As Shape)
        If s.Type = cdrGroupShape Then
            ShowStatusMessage Lang.GetString(eStrGroupSelected)
        ElseIf s.IsSimpleShape And s.Type <> cdrTextShape Then
            ProcessCurve s.DisplayCurve
        Else
            ShowStatusMessage Lang.GetString(eStrInvalidObject)
        End If
    End Sub

    Private Function CheckSubpaths(ByVal crv As Curve) As Boolean
        Dim bRet As Boolean
        Dim n As Long
        bRet = True
        If crv.SubPaths.Count <> 1 Then
            For n = 2 To crv.SubPaths.Count
                If crv.SubPaths(n).Nodes.Count > 1 Then
                    bRet = False
                    Exit For
                End If
            Next n
        End If
        CheckSubpaths = bRet
    End Function

    Private Sub ProcessCurve(ByVal crv As Curve)
        Dim v As Double
        Dim bClearStatus As Boolean
        Dim bClosed As Boolean
       
        bClosed = crv.SubPaths(1).Closed
        bClearStatus = True
        bValidArea = bClosed And CheckSubpaths(crv)
        If bValidArea Then
            grpLength.Caption = Lang.GetString(eCapPerimeter)
            cLength.Caption = Lang.GetString(eCapPerimeter) & ":"
            bPerimeter = True
        Else
            grpLength.Caption = Lang.GetString(eCapLength)
            cLength.Caption = Lang.GetString(eCapLength) & ":"
            bPerimeter = False
        End If
       
        bValidSelection = True
        vLength = crv.Length
       
        If bValidArea Then
            vArea = calcShapeArea(crv.SubPaths(1))
        Else
            vArea = 0
            If bClosed Then
                ShowStatusMessage Lang.GetString(eStrMultipathCurve)
            Else
                ShowStatusMessage Lang.GetString(eStrCurveOpen)
            End If
            bClearStatus = False
        End If
       
        If bClearStatus Then ClearStatusMessage
        UpdateValues
    End Sub

    Private Sub UpdateValues()
        Dim v As Double
        txtLength.Text = FormatValue(GetLength(vLength))
       
        If bValidArea Then
            v = GetArea(vArea)
            txtArea.Text = FormatValue(v)
            txtVolume.Text = FormatValue(v * vDepth)
        Else
            txtArea.Text = ""
            txtVolume.Text = ""
        End If
    End Sub

    Private Function FormatValue(ByVal v As Double) As String
        Dim sFormat As String
        sFormat = "0"
        If cPrecision.GetValue() > 0 Then
            sFormat = "0." & String$(cPrecision.GetValue(), "0")
        End If
        FormatValue = Format$(v, sFormat)
    End Function

    Private Function GetAppUnits(ByVal vUnit As Long) As cdrUnit
        Dim tUnit As cdrUnit
        Select Case CurUnit
            Case 1
                tUnit = cdrMillimeter
            Case 2
                tUnit = cdrCentimeter
            Case 3
                tUnit = cdrMeter
            Case Else
                tUnit = cdrInch
        End Select
        GetAppUnits = tUnit
    End Function

    Private Function GetLength(ByVal v As Double) As Double
        If ActiveDocument Is Nothing Then
            GetLength = 0
        Else
            GetLength = ActiveDocument.FromUnits(v, GetAppUnits(CurUnit)) * ActiveDocument.WorldScale
        End If
    End Function

    Private Function GetArea(ByVal v As Double) As Double
        GetArea = GetLength(GetLength(v))
    End Function

    Private Function calcShapeArea(ByVal sp As SubPath) As Double
        Dim cx As New Collection
        Dim cy As New Collection
        Dim seg As Segment
        Dim n As Long
        Dim x As Double, y As Double
        Dim Area As Double
        Dim nPts As Long
       
        sp.StartNode.GetPosition x, y
       
        cx.Add x
        cy.Add y
       
        For Each seg In sp.Segments
            If seg.Type = cdrCurveSegment Then
                For n = 1 To 49
                    seg.GetPointPositionAt x, y, n / 50
                    cx.Add x
                    cy.Add y
                Next n
            End If
            seg.EndNode.GetPosition x, y
            cx.Add x
            cy.Add y
        Next seg
       
        Area = 0
        For n = 1 To cx.Count - 1
            Area = Area + cx(n) * cy(n + 1) - cy(n) * cx(n + 1)
        Next
       
        calcShapeArea = Abs(Area / 2)
    End Function

    Private Sub ShowStatusMessage(ByVal msg As String)
        lblStatusBar.Caption = msg
    End Sub

    Private Sub ClearStatusMessage()
        lblStatusBar.Caption = ""
    End Sub

    Private Sub UserForm_Terminate()
        MacroRunning = False
    End Sub

    Private Function GetDataString(ByVal bUnicode As Boolean)
        Dim s As String
        s = ""
        If bValidSelection Then
            If cLength.Value Then
                If bPerimeter Then
                    s = Lang.GetString(eCapPerimeter)
                Else
                    s = Lang.GetString(eCapLength)
                End If
                s = s & " = " & txtLength.Text & " " & GetCurUnitString()
            End If
           
            If bValidArea Then
                If cArea.Value Then
                    If s <> "" Then s = s & vbCrLf
                    s = s & Lang.GetString(eCapArea) & " = " & txtArea.Text & " " & GetCurUnitString() & GetSquare(bUnicode)
                End If
               
                If cVolume.Value Then
                    If s <> "" Then s = s & vbCrLf
                    s = s & Lang.GetString(eCapVolume) & " = " & txtVolume.Text & " " & GetCurUnitString() & GetCube(bUnicode)
                End If
            End If
        End If
        GetDataString = s
    End Function

    3、加多模块,名称叫“Information”,代码如下:

    Option Explicit

    Public MacroRunning As Boolean
    Public Updating As Long

    Public Sub Dialog()
        EventsEnabled = True
        frmGeoMetric.Show vbModeless
    End Sub

    4、加多八个类模块:

      (1卡塔尔名称叫clsIntSpin,代码如下:

    Option Explicit

    Public Event Change()

    '================= Private Data =================
    Private WithEvents cTxt As TextBox
    Private WithEvents cSpin As SpinButton
    Private Updating As Long
    Private Value As Long
    Private lLabel As Label
    Private Digits As Long

    '================= Interface ================
    Public Sub Init(Txt As TextBox, Spin As SpinButton, ByVal v As Long, Optional CtlLabel As Label, Optional ByVal nMin As Long = 0, Optional ByVal nMax As Long = 2147483647, Optional ByVal nStep As Long = 1, Optional ByVal NumDigits As Long)
        If v < nMin Then v = nMin
        If v > nMax Then v = nMax
        Value = v
        Set cTxt = Txt
        Set cSpin = Spin
        Set lLabel = CtlLabel
        BeginUpdate
        If NumDigits > 0 Then
            Digits = NumDigits
        Else
            Digits = 1
        End If
       
        cTxt.Value = FormatValue(Value)
        With cSpin
            .Min = nMin
            .Max = nMax
            .SmallChange = nStep
            .Value = Value
        End With
       
        EndUpdate
    End Sub

    Public Function OnTextExit() As Boolean
        Dim n As Long
        OnTextExit = False
        If Updating = 0 Then
            n = GetTextValue()
            BeginUpdate
            If cSpin.Value <> n Then
                cSpin.Value = n
                Value = n
                OnTextExit = True
                RaiseEvent Change
            Else
                cTxt.Value = FormatValue(n)
            End If
            EndUpdate
        End If
    End Function

    Public Sub SetValue(ByVal nVal As Long)
        BeginUpdate
        With cSpin
            If nVal < .Min Then nVal = .Min
            If nVal > .Max Then nVal = .Max
            .Value = nVal
        End With
        Value = nVal
        cTxt.Value = FormatValue(nVal)
        EndUpdate
    End Sub

    Public Function GetValue() As Long
        GetValue = Value
    End Function

    Public Sub Enable(ByVal bState As Boolean)
        If Not lLabel Is Nothing Then lLabel.Enabled = bState
        cTxt.Locked = Not bState
        cTxt.TabStop = bState
        cTxt.BackColor = IIf(bState, vbWindowBackground, vbButtonFace)
        cTxt.ForeColor = IIf(bState, vbWindowText, vbButtonShadow)
        cSpin.Enabled = bState
    End Sub

    Public Sub SetMaxRange(ByVal nVal)
        BeginUpdate
        If Value > nVal Then
            Value = nVal
            cSpin.Value = nVal
            cTxt.Value = FormatValue(nVal)
        End If
        cSpin.Max = nVal
        EndUpdate
    End Sub

    Public Sub SetMinRange(ByVal nVal)
        BeginUpdate
        If Value < nVal Then
            Value = nVal
            cSpin.Value = nVal
            cTxt.Value = FormatValue(nVal)
        End If
        cSpin.Min = nVal
        EndUpdate
    End Sub

    '================ Helper Functions ==============
    Private Sub BeginUpdate()
        Updating = Updating + 1
    End Sub

    Private Sub EndUpdate()
        Updating = Updating - 1
    End Sub

    Private Function GetTextValue() As Long
        Dim v As Double
        v = 0
        If Trim$(cTxt.Text) <> "" Then v = Val(cTxt.Text)
        If v < CDbl(cSpin.Min) Then v = cSpin.Min
        If v > CDbl(cSpin.Max) Then v = cSpin.Max
        GetTextValue = CLng(v)
    End Function

    Private Function FormatValue(ByVal v As Long) As String
        Dim s As String
        Dim bNegative As Boolean
       
        bNegative = v < 0
        s = Trim$(str$(Abs(v)))
        If Len(s) < Digits Then
            s = Right$(String$(Digits, "0") & s, Digits)
        End If
       
        If bNegative Then s = "-" & s
        FormatValue = s
    End Function

    Private Sub Class_Initialize()
        Value = 0
    End Sub

    Private Sub cSpin_Change()
        If Updating = 0 Then
            BeginUpdate
            cTxt.Value = FormatValue(cSpin.Value)
            Value = cSpin.Value
            RaiseEvent Change
            EndUpdate
        End If
    End Sub

    Private Sub cTxt_Change()
        Dim n As Long
        If Updating = 0 Then
            n = GetTextValue()
            If cSpin.Value <> n Then
                BeginUpdate
                cSpin.Value = n
                Value = n
                EndUpdate
                RaiseEvent Change
            End If
        End If
    End Sub

     

      (2卡塔尔名称叫clsLang,代码如下:

    Option Explicit

    Private colDict As New Collection
    Private bMetric As Boolean

    Private Sub Class_Initialize()
     
         AddString eFormCaption, "Geometric Information"
        AddString eBtnClose, "关闭"
        AddString eBtnCopy, "复制"
        AddString eBtnCreateText, "创设文本"
        AddString eBtnRefresh, "刷新"
        AddString eBtnReset, "清零"
        AddString eCapArea, "面积"
        AddString eCapLength, "长度"
        AddString eCapPerimeter, "周长"
        AddString eCapVolume, "体积"
        AddString eCapDepth, "高度"
        AddString eCapUnits, "单位"
        AddString eCapPrecision, "精度"
        AddString eUnitInch, "in"
        AddString eUnitMM, "mm"
        AddString eUnitCM, "cm"
        AddString eUnitM, "m"
        AddString eStrInch, "英寸 (in)"
       
        AddString eStrMM, "毫米 (mm)"
        AddString eStrCM, "厘米 (cm)"
        AddString eStrM, "米 (m)"
        AddString eStrError, "Error"
        AddString eStrNoSelection, "未采取任何图形"
        AddString eStrGroupSelected, "不辅助群组图形,请选取单个图形"
        AddString eStrInvalidObject, "无效接受"
        AddString eStrCurveOpen, "非闭合图形不能测算面积和体量"
        AddString eStrMultipathCurve, "组合图形无法测算面积和体量"
    End Sub

    Private Sub AddString(ByVal eId As ELangStringID, ByVal s As String)
        Dim tPair As New clsLangPair
        tPair.eId = eId
        tPair.sDef = s
        colDict.Add tPair
    End Sub

    Public Function GetString(ByVal eId As ELangStringID) As String
        Dim tPair As clsLangPair
        Dim s As String
        s = "Str #" & eId
        For Each tPair In colDict
            If tPair.eId = eId Then
                s = tPair.sDef
                Exit For
            End If
        Next tPair
        GetString = s
    End Function

    Public Function IsMetric() As Boolean
        IsMetric = bMetric
    End Function

     

      (3卡塔 尔(英语:State of Qatar)名为clsLangPair,代码如下:

    Option Explicit

    Public Enum ELangStringID
        eFormCaption
        eBtnClose
        eBtnCopy
        eBtnCreateText
        eBtnRefresh
        eBtnReset
        eCapArea
        eCapLength
        eCapPerimeter
        eCapVolume
        eCapDepth
        eCapUnits
        eCapPrecision
        eUnitInch
        eUnitMM
        eUnitCM
        eUnitM
        eStrInch
        eStrMM
        eStrCM
        eStrM
        eStrError
        eStrNoSelection
        eStrGroupSelected
        eStrInvalidObject
        eStrCurveOpen
        eStrMultipathCurve
    End Enum

    Public eId As ELangStringID
    Public sDef As String

        以往全体编写落成,按F5键运维吧,选中图形,点击程序中“刷新”,“面积”,“体量”等数码及时展现出来,程序运营效果如下图:

     图片 20

    本文由澳门新葡8455最新网站发布于澳门新葡萄京娱乐场,转载请注明出处:X3计算封闭曲线长度和面积,Excel怎么抓取网络数

    关键词:

上一篇:没有了

下一篇:没有了