帮忙看下应该怎么才能运行,这一段用Dcollection和Levelsection总是显示未定义
Option Explicit
Dim qsd As New DCollection '起算点列表
Dim wzd As New DCollection '未知点列表
Dim sections() As New LevelSection '测段
Dim kNum As Integer '已知点数
Dim sNum As Integer '测段数
Dim msNum As Integer '必要观测数
Dim fDegree As Integer '自由度
Dim uWeight As Double '单位权
Dim uWeight0 As Double '先验单位权
Dim tDistance As Double '总距离数
Dim tPoints As Integer '总点数
Dim pvv As Double '用于精度评定
Const eps As Double = 0.00000001 '缺省精度
Private Function readQsd(dlist() As String) As DCollection '读取起算点数据
Dim bm As Benchmark, ds() As String, d As Variant, bs As New DCollection
For Each d In dlist
Set bm = New Benchmark
ds = Split(d, ",")
bm.id = UCase(ds(0))
bm.appH = Val(ds(1))
bm.known = True
If bs.ExistsKey(bm.id) = False Then
bs.Add bm, bm.id
End If
Next
Set readQsd = bs
End Function
Private Function readObs(dlist() As String) As LevelSection() '读取起算点数据
Dim ss() As New LevelSection, ds() As String, i As Integer, j As Integer
j = UBound(dlist)
ReDim ss(j) As New LevelSection
For i = 0 To j
ds = Split(dlist(1), ",")
ss(i).fromID = UCase(ds(0))
ss(i).toID = UCase(ds(1))
ss(i).Observe = Val(ds(2))
ss(i).Distance = Val(ds(3))
Next i
End Function
Private Function SplitLine(ByVal s As String) As String() '分解格式数据
s = Replace(s, Chr(9), " ")
s = Replace(s, " ", " ")
s = Replace(s, Chr(13), " ")
s = Replace(s, Chr(10), " ")
SplitLine Split(Trim(s))
End Function
Public Sub readData(ByVal obsText As String, qsdText As String, ByVal uw As String) '读取数据
Dim bs0 As DCollection '起算点列表
Set bs0 = readQsd(SplitLine(qsdText)) '读取起算点,必须先调用
sections = readObs(SplitLine(obsText)) '读取观测数据
uWeight0 = Val(uw)
Dim bm As Benchmark, s As Variant
For Each s In sections '根据观测数据构建水准点集合
Set bm = New Benchmark
bm.id = s.fromID
If bs0.ExistsKey(bm.id) And qsd.ExistsKey(bm.id) = False Then
bm , appH = bs0.Item(bm.id).appH
bm.adjH = bm.appH
bm.known = True
qsd.Add bm, bm.id
ElseIf bs0.ExistsKey(bm.id) = False And wzd.ExistsKey(bm.id) = False Then
bm.appH = -99999
bm.known = False
wzd.Add bm, bm.id
End If
Set bm = New Benchmark
bm.id = s.tolD
If bs0.ExistsKey(bm.id) And qsd.ExistsKey(bm.id) = False Then
bm.appH = bs0.Item(bm.id).appH
bm.adjH = bm.appH
bm.known = True
qsd.Add bm, bm.id
ElseIf bs0.ExistsKey(bm.id) = False And wzd.ExistsKey(bm.id) = False Then
bm.appH = -99999
bm.known = False
wzd.Add bm, bm.id
End If
Next
sNum = UBound(sections) + 1 '测段数
msNum = wzd.Count '必要观测数=总点数-已知点数
tPoints = kNum + msNum
fDegree = sNum - msNum '自由度=总测段数-必要观测数
End Sub
Public Property Get sectionNum()
sectionNum = UBound(sections) + 1 '测段数
End Property
Public Property Get mustNum()
mustNum = msNum '必要观测数
End Property
Public Property Get freeDegree()
freeDegree = fDegree '自由度=总测段数-必要观测数
End Property
Public Property Get unitWeight()
unitWeight = uWeight '单位权
End Property
Public Property Get totalDistance()
totalDistance = tDistance '总距离
End Property
Public Property Get totalPoints()
totalPoints = tPoints '单位权
End Property
Public Function calcApproximateAltitude() As Boolean '计算近似高程
Dim i As Integer
Dim bm1 As Benchmark, bm2 As Benchmark, s As Variant
For i = 0 To UBound(sections)
For Each s In sections
If qsd.ExistsKey(s.fromID) Then
Set bm1 = qsd.Item(s.fromID)
If wzd.ExistsKey(s.toID) Then
Set bm2 = wzd.Item(s.toID)
bm2.appH = bm1.appH + s.Observe
End If
ElseIf qsd.ExistsKey(s.toID) Then
Set bm2 = qsd.Item(s.toID)
If wzd.ExistsKey(s.fromID) Then
Set bm1 = wzd.Item(s.fromID)
bml.appH = bm2.appH - s.Observe
End If
Set bm1 = wzd.Item(s.fromID)
ElseIf wzd.ExistsKey(s.fromID) And wzd.ExistsKey(s.toID) Then
Set bm1 = wzd.Item(s.fromID)
Set bm2 = wzd.Item(s, .toID)
If (bm1.appH + 9999) > eps And (bm2.appH + 9999) < eps Then
bm2.appH = bm1.appH + s.Observe
ElseIf (bm1.appH + 9999) < eps And (bm2.appH + 9999) > eps Then
bml.appH = bm2.appH - s.Observe
End If
End If
Next
Next i '检测是否有水准点不能推算
For Each s In sections
If wzd.ExistsKey(s.fromID) Then
Set bm1 = wzd.Item(s.fromID)
If Abs(bml.appH + 9999) < eps Then
MsgBox s.fromID + s.toID + "测段中," + bm1.id + "水准点的近似高程不能推算,请检查观测数据。"
calcApproximateAltitude = False
Exit Function
End If
End If
If wzd.ExistsKey(s.toID) Then
Set bm2 = wzd.Item(s.toID)
If Abs(bm2.appH + 9999) < eps Then
MsgBox s.fromID + s.toID + "测段中," + bm2.id + "水准点的近似高程不能推算,请检查观测数据。"
calcApproximateAltitude = False
Exit Function
End If
End If
Next
calcApproximateAltitude = True
End Function
Public Sub buildBlP(mB As Matrix, mL As Matrix, mP As Matrix) '建立误差方程
mB.init sNum, msNum '误差方程系数矩阵
mL.init sNum, 1 'L系数矩阵
mP.init sNum, sNum '权矩阵
Dim bm1 As Benchmark, bm2 As Benchmark, s As LevelSection
Dim row As Integer
For row = 0 To sNum - 1
Set s = sections(row)
If qsd.ExistsKey(s.fromID) Then
Set bm1 = qsd.Item(s.fromID)
ElseIf wzd.ExistsKey(s.fromID) Then
Set bm1 = wzd.Item(s.fromID)
mB.Element(row, wzd.getindex(bm1, id) - 1) = -1
End If
If qsd.ExistsKey(s.toID) Then
Set bm2 = qsd.Item(s, toID)
ElseIf .wzd.ExistsKey(s.tolD) Then
Set bm2 = wzd.Item(s.toID)
mB.Element(row, 0) = (s.Observe - bm2.appH + bm1.appH) * 1000#
mP.Element(row, row) = uWeight0 / s.Distance
Next row
End Sub
Public Sub Adj(B As Matrix, L As Matrix, P As Matrix)
Dim BT As Matrix, w As Matrix, Nbb As Matrix, Nbb1 As Matrix, i As Integer
Set BT = B.transpose()
Set w = BT.multiply(P).multiply(L) '法方程W
Set Nbb = BT.multiply(P).multiply(B) '法方程N
Set Nbb1 = Nbb.invert() '法方程N的逆阵
Dim x As Matrix, v As Matrix
Set x = Nbb1.multiply(w) '高程改正数
Set v = B.multiply(x).subtract(L) '高差改正数
'精度评定
pvv = v.invert().multiply(P).multiply(v).Element(0, 0)
uWeight = Sqr(pvv / fDegree) '计算单位权
Dim LL As Matrix, bm As Benchmark, s As LevelSection
Set LL = B.multiply(Nbb1).multiply(BT)
For i = 0 To msNum - 1 'miNum为必要观测数
Set bm = wzd.Item(i + 1)
bm.adjH = bm.appH + x.Element(i, 0) / 1000#
bm.msError = uWeight * Sqr(Nbb1.Element(i, i))
Next i
tDistance = 0
For i = 0 To sNum - 1
Set s = sections(i)
s.CorrectedValue = v.Element(i, 0)
s.AdjustedObserve = s.Observe + s.CorrectedValue / 1000#
s.meanSquareError = uWeight * Sqr(LL.Element(i, i))
tDistance = tDistance + s.Distance
Next i
End Sub
Public Function outResult()
Dim s As String
Dim newline As String, i As Integer, bm As Variant
Dim j As Integer, ts As Variant
newline = Chr(13) + Chr(10)
s = String(90, "-") + newline
s = s + " APPROXIMATE HEIGHT" + newline '输出近似高程
s = s + String(90, "-") + newline
s = s + " No. Name Height(m) " + newline
s = s + String(90, "-") + newline
j = 0
For Each bm In qsd.Values ' '输出已知点
j = j + 1
s = s + Format(i, String(6, "@")) + Format(bm.id, String(17, "@"))
s = s + Format(Format(bm.appH, "0.0000"), String(12, "@")) + newline
Next
For Each bm In wzd.Values '输出未知点
j = j + 1
s = s + Format(j, String(6, "@")) + Format(bm.id, String(17, "@"))
s = s + Format(Format(bm.appH, "0.0000"), String(12, "@")) + newline
Next
s = s + String(90, "-") + newline '输出已知点高程
s = s + " KNOWN HEIGHT" + newline
s = s + String(90, "-") + newline
For i = 1 To qsd.Count '输出已知点
Set bm = qsd.Item(i)
s = s + Format(i, String(6, "@")) + Format(bm.id, String(17, "@"))
s = s + Format(Format(bm.appH, "0.0000"), String(12, "@")) + newline
Next i
s = s + String(90, "-") + newline '输出测段观测高差
s = s + " MEASURING DATA OF HEIGHT DIFFERENCE" + newline
s = s + String(90, "-") + newline
s = s + " NO. From TO "
s = s + "Observe(m) Distance(km) Weight" + newline
s = s + String(90, "-") + newline
For i = 0 To UBound(sections)
Set ts = sections(i)
s = s + Format(i + 1, String(6, "@")) + Format(ts.fromID, String(18, "@"))
s = s + Format(ts.toID, String(19, "@"))
s = s + Format(Format(ts.Observe, "0.0000"), String(14, "(@"))
s = s + Format(Format(ts.Distance, "0.00"), String(12, "(@"))
s = s + Format(Format(1# / ts.Distance, " 0.000000"), String(15, "(@"))
s = s + newline
Next i
s = s + String(90, "-") + newline '输出平差高程
s = s + " ADJUSTED HEIGHT" + newline
s = s + String(90, "-") + newline
s = s + "No Name Height(m) Mh(mm)" + newline
s = s + String(90, "-") + newline
j = 0
For Each bm In qsd.Values '输出已知点
j = j + 1
s = s + Format(j, String(6, "@")) + Format(bm.id, String(18, "@"))
s = s + Format(Format(bm.adjH, " 0.0000"), String(13, "@"))
s = s + Format(Format(bm.msError, "0.0000"), String(13, "@"))
s = s + newline
Next
For Each bm In wzd.Values '输出未知点
j = j + 1
s = s + Format(j, String(6, "(@")) + Format(bm.id, String(18, "(@"))
s = s + Format(Format(bm.adjH, " 0.0000"), String(13, "(@"))
s = s + Format(Format(bm.msError, " 0.0000"), String(13, "(@"))
s = s + newline
Next
s = s + String(90, "-") + newline
s = s + " ADJUSTED HEIGHT DIFFERENCE" + newline
s = s + String(90, "-") + newline
s = s + " No. From "
s = s + "To Adjusted_dh(m) V(mm) Mdh(mm) " + newline
s = s + String(90, "-") + newline
For i = 0 To UBound(sections)
Set ts = sections(i)
s = s + Format(i + 1, String(6, "@")) + Format(ts.fromID, String(21, "@"))
s = s + Format(ts.toID, String(19, "(@"))
s = s + Format(Format(ts.AdjustedObserve, " 0.0000"), String(20, "@"))
s = s + Format(Format(ts.CorrectedValue, "0.00"), String(10, "@"))
s = s + Format(Format(ts.meanSquareError, "0.00"), String(13, "@")) + newline
Next i
s = s + String(90, "-") + newline
s = s + " UNIT WEIGHT AND PVV " + newline
s = s + String(90, "-") + newline
s = s + " PVV= " + Format(pvv, "0.0000 ") + newline
s = s + " Free Degree=" + Format(fDegree, "####")
相关推荐
【工业自动化】欧姆龙PLC产品线与编程软件应用:从选型架构到调试排错的全流程技术指南
内容概要:本文《欧姆龙PLC与编程软件完全手册》系统介绍了欧姆龙PLC的产品架构、软件体系、通信协议、选型策略及编程调试技巧。重点区分了两大技术平台:基于CX-Programmer的传统C系列(CP/CJ/CS)与基于Sysmac Studio的新一代Sysmac平台(NJ/NX/NY),强调二者在软件生态、寻址方式和通信架构上的根本差异。手册详细对比了各系列PLC的性能参数,并提供与西门子产品的功能对标,帮助用户快速定位。深入讲解了编程操作中的关键问题,如任务结构设计、间接寻址、FB封装陷阱、在线调试五件套等,特别指出“FB使能关闭时状态不初始化”等易出错点。最后汇总了选型路径与现场避坑清单,极具实战指导价值。; 适合人群:具备一定工业自动化基础,从事PLC编程、设备调试、系统集成的研发工程师和技术人员,尤其是从西门子平台转向欧姆龙或参与新项目选型的1-5年经验从业者。; 使用场景及目标:① 新项目选型时判断应选用C系列还是Sysmac平台;② 编程调试过程中掌握高效操作技巧与常见问题排查方法;③ 实现跨平台迁移、系统升级或接手他人项目时规避架构与逻辑陷阱;④ 提升对欧姆龙PLC任务机制、间接寻址、FB设计等高级功能的理解与应用能力。; 阅读建议:本手册理论结合实践,建议按“先架构后操作”的顺序阅读,重点章节需结合实际工程反复演练。特别是FB设计规范、任务切换处理、强制操作收尾流程等内容,应在仿真环境中验证后再应用于现场。注意版本匹配问题,操作前确认所用软件与控制器固件版本兼容。
CISP-CSE注册云安全工程师备考资源包
CISP-CSE注册云安全工程师备考资源包
科技中介服务机构如何通过AI技术降低技术评估与匹配服务的操作门槛?.docx
科技中介服务机构如何通过AI技术降低技术评估与匹配服务的操作门槛?
国央企创新负责人如何借助平台实现创新资源的高效配置与项目落地?.docx
国央企创新负责人如何借助平台实现创新资源的高效配置与项目落地?
高校技术转移办公室人员如何高效筛选并推介科技成果?.docx
高校技术转移办公室人员如何高效筛选并推介科技成果?


VB基础类
