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

时间:2019-11-10 06:50来源:办公软件
问题: 在日常干活中会境遇,知道里面叁个数额,举例姓名,在表格中输入姓名后,想要自动带出网页中该姓名对应的相干数据,比如该姓名的电话,地址等音信,怎么样完毕吗? 作

问题:在日常干活中会境遇,知道里面叁个数额,举例姓名,在表格中输入姓名后,想要自动带出网页中该姓名对应的相干数据,比如该姓名的电话,地址等音信,怎么样完毕吗?

作为世界最优异的矢量图形设计软件CorelDRAW X3(最新版卡塔 尔(阿拉伯语:قطر‎居然未有查询图形周长、面积的效劳,但是作为矢量图形设计软件,查询图形几何属性是必不可缺的,幸而有VBA,给了大家扩展CorelDRAW X3功力的杰出空间,以下便是查询矢量图形几何音信的VBA进程。要是您有Corel Designer 12,   能够在里头找到此作用,将里面包车型地铁窗体,模块,类模块,导出,再到 CorelDRAW X3 VBA中,把它们导过来,运转“宏”就能够在CorelDRAW X3中运转了,若无请看上面宏代码编写进度。

回答:

1、运维CorelDRAW X3,新建“图形1”,按“Alt+F11”张开Visual Basic编辑器,增加如下图所示客户窗体,名为“frm吉优metric”:图片 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宝马X3L栏,并点击鲜明。

图片 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二零零二为例来给您作证。

意气风发、首先张开EXCEL二零零三,在菜单栏找到“数据”然后在下拉菜单点击“导入外界数据-新建WEB查询”
图片 17
二、然后在展开的对话框中的地址栏中,将你要导入的网站输入进去,按下转到开关。
图片 18
三、在弹开的对话框中原则必要导入的区域,按下导入按钮,当时,数据就被导入到EXCEL里面啦!
图片 19最终,你的Computer得链接网络,要不未有数据,这样导入的利润是,可以和网址上保持豆蔻年华致,无需进行手动更新,很有利。

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

编辑:办公软件 本文来源:Excel怎么抓取网络数据,X3计算封闭曲线长度和面

关键词:

  • 上一篇:没有了
  • 下一篇:没有了