Public ZH As Double, hxjl As Double, XXX As Double, YYY As Double, FWJ As Double
Public YESGCJS
Public Const π As Double = 3.14159265358979
Public Type NE
N As Double
E As Double
End Type
Public Sub SimpsZBJS(StartZH As Double, StartN As Double, StartE As Double, StartFWJ As Double, StartQLR As Double, EndQLR As Double, Ength As Double, AskZH As Double, step As Integer)
Dim K As Double, SubFWJ As Double, H As Double, i As Integer, x As Double
Dim a As Double, b As Double
Dim FourN As Double, TwoN As Double, SN As Double
Dim FourE As Double, TwoE As Double, SE As Double
XXX = 0
YYY = 0
K = (EndQLR - StartQLR) / Ength / 2
If step > 10000 Then step = 10000
step = 6000 + step
H = (AskZH - StartZH) / step / 2
a = 0
b = AskZH - StartZH
x = a
FWJ = StartFWJ + StartQLR * b + K * b ^ 2
If FWJ < 0 Then FWJ = FWJ + 2 * π
If FWJ > 2 * π Then FWJ = FWJ - 2 * π
SN = Cos(StartFWJ) + Cos(FWJ)
SE = Sin(StartFWJ) + Sin(FWJ)
For i = 1 To step
x = x + H
SubFWJ = StartFWJ + StartQLR * x + K * x ^ 2
FourN = FourN + Cos(SubFWJ)
FourE = FourE + Sin(SubFWJ)
x = x + H
SubFWJ = StartFWJ + StartQLR * x + K * x ^ 2
TwoN = TwoN + Cos(SubFWJ)
TwoE = TwoE + Sin(SubFWJ)
Next i
TwoN = TwoN - Cos(SubFWJ)
TwoE = TwoE - Sin(SubFWJ)
SN = SN + 4 * FourN + 2 * TwoN
SE = SE + 4 * FourE + 2 * TwoE
XXX = StartN + SN * H / 3
YYY = StartE + SE * H / 3
End Sub
Public Function QL(R As Double)
If R < 0.000000001 Then
QL = 0
Else: QL = 1 / R
End If
End Function
Public Sub ZBJS(AskZH As Double, AskHXJL As Double)
Dim StartZH As Double, StartN As Double, StartE As Double, StartFWJ As Double, StartQLR As Double, EndQLR As Double, Ength As Double, SubFWJ As Double
Dim Row As Integer, Column As Integer, i As Integer
Dim ysds As Integer
Dim dqys As Integer
Row = 6
Column = 1
ysds = Worksheets("SIMPSYS").Cells(1, 7).Value
dqys = Worksheets("SIMPSYS").Cells(2, 7).Value
For i = 1 To ysds
If AskZH > Worksheets("SIMPSYS").Cells(Row + dqys, Column).Value + Worksheets("SIMPSYS").Cells(Row + dqys, Column + 6).Value Then
If dqys >= ysds Then
XXX = 0
YYY = 0
MsgBox ("请求里程超出要素范围up")
Worksheets("SIMPSYS").Cells(2, 7).Value = ysds
End
End If
dqys = dqys + 1
ElseIf AskZH > Worksheets("SIMPSYS").Cells(Row + dqys, Column).Value Then
Exit For
Else:
dqys = dqys - 1
If dqys < 1 Then
XXX = 0
YYY = 0
MsgBox ("请求里程超出要素范围do")
Worksheets("SIMPSYS").Cells(2, 7).Value = 1
End
End If
End If
Next i
Worksheets("SIMPSYS").Cells(2, 7).Value = dqys
StartZH = Worksheets("SIMPSYS").Cells(Row + dqys, Column).Value
StartN = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 1).Value
StartE = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 2).Value
StartFWJ = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 3).Value
StartQLR = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 4).Value
EndQLR = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 5).Value
Ength = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 6).Value
Call SimpsZBJS(StartZH, StartN, StartE, StartFWJ, StartQLR, EndQLR, Ength, AskZH, 0)
SubFWJ = 0
SubFWJ = FWJ + π / 2
XXX = XXX + Cos(SubFWJ) * AskHXJL
YYY = YYY + Sin(SubFWJ) * AskHXJL
End Sub
Public Sub ZBFS(SubN As Double, SubE As Double)
Dim x As Double, y As Double, d As Double, a As Double, b As Double, SubZH As Double, i As Integer
i = 0
dqys = Worksheets("SIMPSYS").Cells(2, 7).Value
ZH = Worksheets("SIMPSYS").Cells(6 + dqys, 1).Value + 1
Call ZBJS(ZH, 0)
JS:
i = i + 1
x = SubN - XXX
y = SubE - YYY
d = Sqr(x ^ 2 + y ^ 2)
If x = 0 Then
a = π / 2
GoTo AA
End If
a = Atn(y / x)
AA:
If x < 0 Then a = a + π
If a < 0 Then a = a + 2 * π
b = a - FWJ
SubZH = Cos(b) * d
ZH = ZH + SubZH
If Abs(SubZH) > 0.00001 Then
Call ZBJS(ZH, 0)
If i > 10000 Then GoTo BBB:
GoTo JS
End If
BBB:
hxjl = Sin(b) * d
End Sub
Public Sub PQXYSJS()
Dim SubStartD As NE, SubJD As NE, SubEndD As NE, SubSTZH As Double, SubFWJ As Double, SubEngth As Double
Dim Row1 As Integer, Column1 As Integer, Row2 As Integer, column2 As Integer, JdZDS As Integer
Dim SubLH1 As Double, SubR As Double, SubLH2 As Double, SubB1 As Double, SubB2 As Double
Dim SubT1 As Double, SubT2 As Double, SubYHL As Double, SubJDL1 As Double, SubJDL2 As Double
Dim SubP1 As Double, SubP2 As Double, SubQ1 As Double, SubQ2 As Double, x As Double, y As Double, Subfwj1 As Double, Subfwj2 As Double
Dim SubZJ As Double, Sublsj As Double, SublsZH As Double, j As Integer
Dim ysds As Integer
Row1 = 4
Column1 = 1
Row2 = 7
column2 = 1
ysds = 0
Worksheets("SIMPSYS").Range("H:H").ClearContents
Worksheets("SIMPSYS").Range("I:I").ClearContents
Worksheets("SIMPSYS").Cells(1, 7).Formula = "=MAX(H:H)"
Worksheets("SIMPSYS").Cells(2, 7).Value = 1
Worksheets("SIMPSYS").Cells(7, 13).Formula = "=RADIANS((L7-INT(L7/100)*100+(INT(L7/100)-INT(L7/10000)*100)*60+INT(L7/10000)*3600)/3600)"
Worksheets("SIMPSYS").Cells(7, 11).Formula = "=ql(J7)"
SubSTZH = Worksheets("JDYS").Range("G4")
JdZDS = Worksheets("JDYS").Range("I1")
SubStartD.N = Worksheets("JDYS").Cells(Row1, Column1 + 1).Value
SubStartD.E = Worksheets("JDYS").Cells(Row1, Column1 + 2).Value
Row1 = Row1 + 1
SubJD.N = Worksheets("JDYS").Cells(Row1, Column1 + 1).Value
SubJD.E = Worksheets("JDYS").Cells(Row1, Column1 + 2).Value
x = SubJD.N - SubStartD.N
y = SubJD.E - SubStartD.E
SubJDL1 = Sqr(x ^ 2 + y ^ 2)
If x = 0 Then
Subfwj1 = π / 2
Else
Subfwj1 = Atn(y / x)
End If
If x < 0 Then Subfwj1 = Subfwj1 + π
If Subfwj1 < 0 Then Subfwj1 = Subfwj1 + 2 * π
Worksheets("SIMPSYS").Cells(Row2, column2).Value = SubSTZH
Worksheets("SIMPSYS").Cells(Row2, Column1 + 1).Value = SubStartD.N
Worksheets("SIMPSYS").Cells(Row2, Column1 + 2).Value = SubStartD.E
SubJDZH = SubSTZH + SubJDL1
For i = 1 To JdZDS
SubLH1 = Worksheets("JDYS").Cells(Row1, Column1 + 3).Value
SubR = Worksheets("JDYS").Cells(Row1, Column1 + 4).Value
SubLH2 = Worksheets("JDYS").Cells(Row1, Column1 + 5).Value
Row1 = Row1 + 1
SubEndD.N = Worksheets("JDYS").Cells(Row1, Column1 + 1).Value
SubEndD.E = Worksheets("JDYS").Cells(Row1, Column1 + 2).Value
x = SubEndD.N - SubJD.N
y = SubEndD.E - SubJD.E
SubJDL2 = Sqr(x ^ 2 + y ^ 2)
If x = 0 Then
Subfwj2 = π / 2
Else
Subfwj2 = Atn(y / x)
End If
If x < 0 Then Subfwj2 = Subfwj2 + π
If Subfwj2 < 0 Then Subfwj2 = Subfwj2 + 2 * π
SubZJ = Subfwj2 - Subfwj1
If Abs(SubZJ) > π Then
If SubZJ > 0 Then
SubZJ = SubZJ - 2 * π
Else: SubZJ = SubZJ + 2 * π
End If
End If
If SubZJ < 0 Then
j = -1
Else
j = 1
End If
XXX = 0
YYY = 0
SubB1 = 0
If SubLH1 <> 0 Then
Call SimpsZBJS(0, 0, 0, 0, 0, QL(SubR), SubLH1, SubLH1, 10000)
SubB1 = SubLH1 / 2 / SubR
End If
SubQ1 = YYY - SubR * (1 - Cos(SubB1))
SubP1 = XXX - SubR * Sin(SubB1)
XXX = 0
YYY = 0
SubB2 = 0
If SubLH2 <> 0 Then
Call SimpsZBJS(0, 0, 0, 0, 0, QL(SubR), SubLH2, SubLH2, 10000)
SubB2 = SubLH2 / 2 / SubR
End If
SubQ2 = YYY - SubR * (1 - Cos(SubB2))
SubP2 = XXX - SubR * Sin(SubB2)
Sublsj = Abs(π / 2 - Abs(SubZJ))
SubT1 = SubR * Tan(Abs(SubZJ / 2)) + SubP1 + SubQ2 / Cos(Sublsj) - SubQ1 * Tan(Sublsj)
SubT2 = SubR * Tan(Abs(SubZJ / 2)) + SubP2 + SubQ1 / Cos(Sublsj) - SubQ2 * Tan(Sublsj)
SubYHL = Abs(Abs(SubZJ) - SubB1 - SubB2) * SubR
x = SubStartD.N ' 用于处理开头就是零长直线
y = SubStartD.E
STDorHZD:
SubEngth = SubJDZH - SubT1 - SubSTZH
SubFWJ = Subfwj1
If SubEngth < 0.0006 Then GoTo ZHD
Worksheets("SIMPSYS").Cells(Row2, column2 + 3).Value = SubFWJ
Worksheets("SIMPSYS").Cells(Row2, column2 + 4).Value = 0
Worksheets("SIMPSYS").Cells(Row2, column2 + 5).Value = 0
Worksheets("SIMPSYS").Cells(Row2, column2 + 6).Value = SubJDZH - SubT1 - SubSTZH
ysds = ysds + 1
Worksheets("SIMPSYS").Cells(Row2, column2 + 7).Value = ysds
Worksheets("SIMPSYS").Cells(Row2, column2 + 8).Formula = "=TRUNC(DEGREES(D" & Row2 & "))*10000+TRUNC((DEGREES(D" & Row2 & ")-TRUNC(DEGREES(D" & Row2 & ")))*60)*100+ROUND(((((DEGREES(D" & Row2 & ")-TRUNC(DEGREES(D" & Row2 & ")))*60)-TRUNC((DEGREES(D" & Row2 & ")-TRUNC(DEGREES(D" & Row2 & ")))*60))*60),2)"
Row2 = Row2 + 1
SubSTZH = SubJDZH - SubT1
ZHD:
Worksheets("SIMPSYS").Cells(Row2, column2).Value = SubSTZH
x = SubJD.N - SubT1 * Cos(Subfwj1)
y = SubJD.E - SubT1 * Sin(Subfwj1)
Worksheets("SIMPSYS").Cells(Row2, Column1 + 1).Value = x
Worksheets("SIMPSYS").Cells(Row2, Column1 + 2).Value = y
SubFWJ = Subfwj1
Worksheets("SIMPSYS").Cells(Row2, column2 + 3).Value = SubFWJ
If Abs(SubLH1) < 0.000000000001 Then
GoTo ZYD
End If
Worksheets("SIMPSYS").Cells(Row2, column2 + 4).Value = 0
Worksheets("SIMPSYS").Cells(Row2, column2 + 5).Value = j * QL(SubR)
Worksheets("SIMPSYS").Cells(Row2, column2 + 6).Value = SubLH1
ysds = ysds + 1
Worksheets("SIMPSYS").Cells(Row2, column2 + 7).Value = ysds
Worksheets("SIMPSYS").Cells(Row2, column2 + 8).Formula = "=TRUNC(DEGREES(D" & Row2 & "))*10000+TRUNC((DEGREES(D" & Row2 & ")-TRUNC(DEGREES(D" & Row2 & ")))*60)*100+ROUND(((((DEGREES(D" & Row2 & ")-TRUNC(DEGREES(D" & Row2 & ")))*60)-TRUNC((DEGREES(D" & Row2 & ")-TRUNC(DEGREES(D" & Row2 & ")))*60))*60),2)"
HYD:
Row2 = Row2 + 1
SubSTZH = SubSTZH + SubLH1
Worksheets("SIMPSYS").Cells(Row2, column2).Value = SubSTZH
Call SimpsZBJS(0, x, y, Subfwj1, 0, j * QL(SubR), SubLH1, SubLH1, 10000)
x = XXX
y = YYY
SubFWJ = FWJ
Worksheets("SIMPSYS").Cells(Row2, Column1 + 1).Value = x
Worksheets("SIMPSYS").Cells(Row2, Column1 + 2).Value = y
Worksheets("SIMPSYS").Cells(Row2, column2 + 3).Value = SubFWJ
ZYD:
Worksheets("SIMPSYS").Cells(Row2, column2 + 4).Value = j * QL(SubR)
Worksheets("SIMPSYS").Cells(Row2, column2 + 5).Value = j * QL(SubR)
Worksheets("SIMPSYS").Cells(Row2, column2 + 6).Value = SubYHL
ysds = ysds + 1
Worksheets("SIMPSYS").Cells(Row2, column2 + 7).Value = ysds
Worksheets("SIMPSYS").Cells(Row2, column2 + 8).Formula = "=TRUNC(DEGREES(D" & Row2 & "))*10000+TRUNC((DEGREES(D" & Row2 & ")-TRUNC(DEGREES(D" & Row2 & ")))*60)*100+ROUND(((((DEGREES(D" & Row2 & ")-TRUNC(DEGREES(D" & Row2 & ")))*60)-TRUNC((DEGREES(D" & Row2 & ")-TRUNC(DEGREES(D" & Row2 & ")))*60))*60),2)"
YHD:
SubSTZH = SubSTZH + SubYHL
If Abs(SubLH2) < 0.000000000001 Then
GoTo YZD
End If
Row2 = Row2 + 1
Worksheets("SIMPSYS").Cells(Row2, column2).Value = SubSTZH
Sublsj = j * (Abs(SubZJ) - SubB1 - SubB2)
If SubFWJ < 0 Then SubFWJ = SubFWJ + 2 * π
If SubFWJ > 2 * π Then SubFWJ = SubFWJ - 2 * π
x = x + Cos(SubFWJ + Sublsj / 2) * SubR * Sin(Abs(Sublsj / 2)) * 2
y = y + Sin(SubFWJ + Sublsj / 2) * SubR * Sin(Abs(Sublsj / 2)) * 2
Worksheets("SIMPSYS").Cells(Row2, Column1 + 1).Value = x
Worksheets("SIMPSYS").Cells(Row2, Column1 + 2).Value = y
SubFWJ = SubFWJ + Sublsj
Worksheets("SIMPSYS").Cells(Row2, column2 + 3).Value = SubFWJ
Worksheets("SIMPSYS").Cells(Row2, column2 + 4).Value = j * QL(SubR)
Worksheets("SIMPSYS").Cells(Row2, column2 + 5).Value = 0
Worksheets("SIMPSYS").Cells(Row2, column2 + 6).Value = SubLH2
ysds = ysds + 1
Worksheets("SIMPSYS").Cells(Row2, column2 + 7).Value = ysds
Worksheets("SIMPSYS").Cells(Row2, column2 + 8).Formula = "=TRUNC(DEGREES(D" & Row2 & "))*10000+TRUNC((DEGREES(D" & Row2 & ")-TRUNC(DEGREES(D" & Row2 & ")))*60)*100+ROUND(((((DEGREES(D" & Row2 & ")-TRUNC(DEGREES(D" & Row2 & ")))*60)-TRUNC((DEGREES(D" & Row2 & ")-TRUNC(DEGREES(D" & Row2 & ")))*60))*60),2)"
HZD:
YZD:
Row2 = Row2 + 1
SubSTZH = SubSTZH + SubLH2
Worksheets("SIMPSYS").Cells(Row2, column2).Value = SubSTZH
x = SubJD.N + SubT2 * Cos(Subfwj2)
y = SubJD.E + SubT2 * Sin(Subfwj2)
Worksheets("SIMPSYS").Cells(Row2, Column1 + 1).Value = x
Worksheets("SIMPSYS").Cells(Row2, Column1 + 2).Value = y
SubStartD = SubJD
SubJD = SubEndD
Subfwj1 = Subfwj2
SubJDZH = SubJDZH - SubT1 + SubLH1 + SubYHL + SubLH2 - SubT2 + SubJDL2
Next i
Worksheets("SIMPSYS").Cells(Row2, column2 + 3).Value = Subfwj1
SubEngth = SubJDZH - SubSTZH
If SubEngth < 0.0006 Then Exit Sub
Worksheets("SIMPSYS").Cells(Row2, column2 + 4).Value = 0
Worksheets("SIMPSYS").Cells(Row2, column2 + 5).Value = 0
Worksheets("SIMPSYS").Cells(Row2, column2 + 6).Value = SubJDZH - SubSTZH
ysds = ysds + 1
Worksheets("SIMPSYS").Cells(Row2, column2 + 7).Value = ysds
Worksheets("SIMPSYS").Cells(Row2, column2 + 8).Formula = "=TRUNC(DEGREES(D" & Row2 & "))*10000+TRUNC((DEGREES(D" & Row2 & ")-TRUNC(DEGREES(D" & Row2 & ")))*60)*100+ROUND(((((DEGREES(D" & Row2 & ")-TRUNC(DEGREES(D" & Row2 & ")))*60)-TRUNC((DEGREES(D" & Row2 & ")-TRUNC(DEGREES(D" & Row2 & ")))*60))*60),2)"
Worksheets("SIMPSYS").Cells(Row2 + 1, Column1).Value = SubJDZH
Worksheets("SIMPSYS").Cells(Row2 + 1, Column1 + 1).Value = SubEndD.N
Worksheets("SIMPSYS").Cells(Row2 + 1, Column1 + 2).Value = SubEndD.E
End Sub
Public Sub GOTOZBFS()
Dim Row As Integer, Column As Integer, SubN As Double, SubE As Double
Dim Row2 As Integer
Dim i As Integer
Row = Selection.Row
Row2 = Row
Column = Selection.Column
If Column < 3 Then
MsgBox ("反算坐标的前面要留两列 ")
MYcopy:
SubN = ActiveSheet.Cells.Cells(Row, Column).Value
SubE = ActiveSheet.Cells.Cells(Row, Column + 1).Value
If Abs(SubN * SubE) < 0.00000000001 Then
Column = 3
Row = Row2
GoTo JS
End If
If Column = 1 Then
ActiveSheet.Cells.Cells(Row, Column + 2).Copy Destination:=ActiveSheet.Cells.Cells(Row, Column + 4)
ActiveSheet.Cells.Cells(Row, Column).Copy Destination:=ActiveSheet.Cells.Cells(Row, Column + 2)
ActiveSheet.Cells.Cells(Row, Column + 1).Copy Destination:=ActiveSheet.Cells.Cells(Row, Column + 3)
ActiveSheet.Cells.Cells(Row, Column).Clear
ActiveSheet.Cells.Cells(Row, Column + 1).Clear
Row = Row + 1
i = i + 1
If i > 1000 Then
Column = 3
Row = Row2
GoTo JS
End If
GoTo MYcopy
End If
If Column = 2 Then
ActiveSheet.Cells.Cells(Row, Column + 2).Copy Destination:=ActiveSheet.Cells.Cells(Row, Column + 3)
ActiveSheet.Cells.Cells(Row, Column + 1).Copy Destination:=ActiveSheet.Cells.Cells(Row, Column + 2)
ActiveSheet.Cells.Cells(Row, Column).Copy Destination:=ActiveSheet.Cells.Cells(Row, Column + 1)
ActiveSheet.Cells.Cells(Row, Column).Clear
Row = Row + 1
i = i + 1
If i > 1000 Then
Column = 3
Row = Row2
GoTo JS
End If
GoTo MYcopy
End If
End If
JS:
SubN = ActiveSheet.Cells.Cells(Row, Column).Value
SubE = ActiveSheet.Cells.Cells(Row, Column + 1).Value
If Abs(SubN * SubE) < 0.00000000001 Then
End
End If
Call ZBFS(SubN, SubE)
If Worksheets("SET").Cells(3, 2).Value > 0 Then ZH = Dlfcl(ZH)
ActiveSheet.Cells(Row, Column - 2).Value = ZH
ActiveSheet.Cells(Row, Column - 1).Value = hxjl
Row = Row + 1
i = i + 1
If i > 1000 Then
End
End If
GoTo JS
End Sub
Public Sub GOTOZBJS()
Dim Row As Integer, Column As Integer, AskZH As Double, AskHXJL As Double
Dim i As Integer
Row = Selection.Row
Column = Selection.Column
JS:
AskZH = ActiveSheet.Cells.Cells(Row, Column).Value
AskHXJL = ActiveSheet.Cells.Cells(Row, Column + 1).Value
If AskZH < 0.00000000001 Then
End
End If
If Worksheets("SET").Cells(2, 2).Value > 0 Then ActiveSheet.Cells(Row, Column + 4).Value = GCJS(AskZH)
If Worksheets("SET").Cells(3, 2).Value > 0 Then AskZH = DLcl(AskZH)
Call ZBJS(AskZH, AskHXJL)
ActiveSheet.Cells(Row, Column + 2).Value = XXX
ActiveSheet.Cells(Row, Column + 3).Value = YYY
Row = Row + 1
i = i + 1
If i > 10000 Then
End
End If
GoTo JS
End Sub
Public Function DLcl(AskZH As Double) As Double
Dim ClZH As Double, DLZH As Double, DLC1 As Double, DLC2 As Double
Dim DLsl As Integer
Dim i As Integer
Dim Row As Integer, Column As Integer
Row = 3: Column = 4
DLsl = Worksheets("SET").Cells(1, 5).Value
DLC1 = 0
DLC2 = 0
For i = 1 To DLsl
ClZH = Worksheets("SET").Cells(Row, Column).Value
DLZH = Worksheets("SET").Cells(Row, Column + 1).Value
DLC2 = ClZH - DLZH
If DLC2 < 0 Then
If AskZH > ClZH Then
If AskZH < DLZH Then
MsgBox "请求桩号无效!!在短断上!!!"
Else
DLC1 = DLC1 + DLC2
End If
End If
Else
If AskZH > DLZH Then
If AskZH < ClZH Then
UserForm1.Show
If Worksheets("SET").Cells(4, 2).Value < 0 Then
DLC1 = DLC1 + DLC2
End If
Else
DLC1 = DLC1 + DLC2
End If
End If
End If
Row = Row + 1
Next i
DLcl = AskZH + DLC1
End Function
Public Function Dlfcl(AskZH As Double) As Double
Dim ClZH As Double, DLZH As Double, AbsZH As Double, DLC1 As Double, DLC2 As Double
Dim DLsl As Integer
Dim i As Integer
Dim Row As Integer, Column As Integer
Row = 3: Column = 4
DLsl = Worksheets("SET").Cells(1, 5).Value
AbsZH = 0
DLC2 = 0
For i = 1 To DLsl
DLC1 = DLC2
ClZH = Worksheets("SET").Cells(Row, Column).Value
DLZH = Worksheets("SET").Cells(Row, Column + 1).Value
AbsZH = ClZH + DLC1
DLC2 = DLC2 + ClZH - DLZH
'DLC2 = ClZH - DLZH
If AskZH < AbsZH Then
Dlfcl = AskZH - DLC1
GoTo MYEND
End If
Row = Row + 1
Next i
Dlfcl = AskZH - DLC2
MYEND:
End Function
Sub SIMPSYSToCAD()
Dim CAD As AutoCAD.AcadApplication
Dim CADDOC As AcadDocument
Dim MYSpace As AcadModelSpace
Dim PLineObj As AcadLWPolyline
Dim LineObj As AcadLine
Dim ArcObj As AcadArc
On Error Resume Next
Set CAD = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set CAD = CreateObject("AutoCAD.Application") '若 AutoCad未启动，则运行它
If Err Then
Dim msg As String
msg = Err.Description + "! 检查CAD安装是否正确"
MsgBox msg
Exit Sub
End If
End If
CAD.Visible = True
Set CADDOC = CAD.ActiveDocument
Set MYSpace = CADDOC.ModelSpace
Dim StartZH As Double, StartN As Double, StartE As Double, StartFWJ As Double, StartQLR As Double, EndQLR As Double, Ength As Double, SubFWJ As Double
Dim EndFWJ As Double, GDZ As Double
Dim EndN As Double, EndE As Double
Dim Row As Integer, Column As Integer, i As Integer
Dim ysds As Integer
Dim dqys As Integer
Dim PLineP() As Double
Dim ID As Integer
Dim setp As Integer
Dim SubR As Double
setp = 5
Row = 6
Column = 1
ysds = Worksheets("SIMPSYS").Cells(1, 7).Value
For dqys = 1 To ysds
StartZH = Worksheets("SIMPSYS").Cells(Row + dqys, Column).Value
StartN = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 1).Value
StartE = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 2).Value
StartFWJ = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 3).Value
StartQLR = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 4).Value
EndQLR = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 5).Value
Ength = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 6).Value
EndN = Worksheets("SIMPSYS").Cells(Row + dqys + 1, Column + 1).Value
EndE = Worksheets("SIMPSYS").Cells(Row + dqys + 1, Column + 2).Value
If Abs(StartQLR + EndQLR) < 0.000000000000001 Then
Erase PLineP
ReDim PLineP(3) As Double
PLineP(0) = StartE: PLineP(1) = StartN
PLineP(2) = EndE: PLineP(3) = EndN
Set PLineObj = MYSpace.AddLightWeightPolyline(PLineP)
ElseIf Abs(StartQLR * EndQLR) < 0.000000000000001 Or Abs(StartQLR - EndQLR) > 0.000000000000001 Then
Erase PLineP
ID = (Int(Ength / setp) + 1) * 2 + 1
ReDim PLineP(ID) As Double
ID = 0
PLineP(ID) = StartE
ID = ID + 1
PLineP(ID) = StartN
For i = 1 To Int(Ength / setp)
Call SimpsZBJS(0, StartN, StartE, StartFWJ, StartQLR, EndQLR, Ength, i * setp, 10000)
ID = ID + 1
PLineP(ID) = YYY
ID = ID + 1
PLineP(ID) = XXX
Next i
ID = ID + 1
PLineP(ID) = EndE
ID = ID + 1
PLineP(ID) = EndN
Set PLineObj = MYSpace.AddLightWeightPolyline(PLineP)
Else
Erase PLineP
ID = 2
ReDim PLineP(ID) As Double
'EndFWJ = Worksheets("SIMPSYS").Cells(Row + 1 + dqys, Column + 3).Value
Dim K As Double
K = (EndQLR - StartQLR) / Ength / 2
EndFWJ = StartFWJ + StartQLR * Ength + K * Ength ^ 2
If StartQLR < 0 Then
StartFWJ = -StartFWJ
Else: StartFWJ = π - StartFWJ
End If
If StartQLR < 0 Then
EndFWJ = -EndFWJ
Else: EndFWJ = π - EndFWJ
End If
SubR = Abs(1 / StartQLR)
PLineP(0) = StartE - Cos(StartFWJ) * SubR
PLineP(1) = StartN - Sin(StartFWJ) * SubR
PLineP(2) = 0
If StartQLR > 0 Then
GDZ = EndFWJ
EndFWJ = StartFWJ
StartFWJ = GDZ
End If
Set ArcObj = MYSpace.AddArc(PLineP, SubR, StartFWJ, EndFWJ)
End If
Next dqys
Erase PLineP
CADDOC.Application.ZoomAll
End Sub
Public Sub XYtoCAD()
Dim CAD As AutoCAD.AcadApplication
Dim CADDOC As AcadDocument
Dim MYSpace As AcadModelSpace
Dim PLineObj As AcadLWPolyline
Dim LineObj As AcadLine
Dim ArcObj As AcadArc
On Error Resume Next
Set CAD = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set CAD = CreateObject("AutoCAD.Application") '若 AutoCad未启动，则运行它
If Err Then
Dim msg As String
msg = Err.Description + "! 检查CAD安装是否正确"
MsgBox msg
Exit Sub
End If
End If
CAD.Visible = True
Set CADDOC = CAD.ActiveDocument
Set MYSpace = CADDOC.ModelSpace
Dim PLineP() As Double
Dim ID As Integer
Dim Row As Integer, Column As Integer, i As Integer
Dim x As Double, y As Double
Row = Selection.Row
Column = Selection.Column
ID = 1
ReadXY:
y = ActiveSheet.Cells.Cells(Row, Column).Value
x = ActiveSheet.Cells.Cells(Row, Column + 1).Value
If Abs(x * y) < 0.00000000001 Then
GoTo TOCAD
End If
ReDim Preserve PLineP(ID) As Double
PLineP(ID - 1) = x: PLineP(ID) = y
ID = ID + 2
Row = Row + 1
GoTo ReadXY
TOCAD:
Set PLineObj = MYSpace.AddLightWeightPolyline(PLineP)
Erase PLineP
CADDOC.Application.ZoomAll
End Sub
Public Sub ZHGCToCAD()
Dim CAD As AutoCAD.AcadApplication
Dim CADDOC As AcadDocument
Dim MYSpace As AcadModelSpace
Dim PLineObj As AcadLWPolyline
Dim LineObj As AcadLine
Dim ArcObj As AcadArc
On Error Resume Next
Set CAD = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set CAD = CreateObject("AutoCAD.Application") '若 AutoCad未启动，则运行它
If Err Then
Dim msg As String
msg = Err.Description + "! 检查CAD安装是否正确"
MsgBox msg
Exit Sub
End If
End If
CAD.Visible = True
Set CADDOC = CAD.ActiveDocument
Set MYSpace = CADDOC.ModelSpace
Dim PLineP() As Double
Dim ID As Integer
Dim Row As Integer, Column As Integer, i As Integer
Dim x As Double, y As Double
Row = Selection.Row
Column = Selection.Column
ID = 1
ReadXY:
x = ActiveSheet.Cells.Cells(Row, Column).Value
y = ActiveSheet.Cells.Cells(Row, Column + 4).Value
If Abs(x * y) < 0.00000000001 Then
GoTo TOCAD
End If
ReDim Preserve PLineP(ID) As Double
PLineP(ID - 1) = x: PLineP(ID) = y
ID = ID + 2
Row = Row + 1
GoTo ReadXY
TOCAD:
Set PLineObj = MYSpace.AddLightWeightPolyline(PLineP)
Erase PLineP
CADDOC.Application.ZoomAll
End Sub
Public Sub PJGCToCAD()
Dim CAD As AutoCAD.AcadApplication
Dim CADDOC As AcadDocument
Dim MYSpace As AcadModelSpace
Dim PLineObj As AcadLWPolyline
Dim LineObj As AcadLine
Dim ArcObj As AcadArc
On Error Resume Next
Set CAD = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set CAD = CreateObject("AutoCAD.Application") '若 AutoCad未启动，则运行它
If Err Then
Dim msg As String
msg = Err.Description + "! 检查CAD安装是否正确"
MsgBox msg
Exit Sub
End If
End If
CAD.Visible = True
Set CADDOC = CAD.ActiveDocument
Set MYSpace = CADDOC.ModelSpace
Dim PLineP() As Double
Dim ID As Integer
Dim Row As Integer, Column As Integer, i As Integer
Dim x As Double, y As Double
Row = Selection.Row
Column = Selection.Column
ID = 1
ReadXY:
x = ActiveSheet.Cells.Cells(Row, Column).Value
y = ActiveSheet.Cells.Cells(Row, Column + 3).Value
If Abs(x * y) < 0.00000000001 Then
GoTo TOCAD
End If
ReDim Preserve PLineP(ID) As Double
PLineP(ID - 1) = x: PLineP(ID) = y
ID = ID + 2
Row = Row + 1
GoTo ReadXY
TOCAD:
Set PLineObj = MYSpace.AddLightWeightPolyline(PLineP)
Erase PLineP
CADDOC.Application.ZoomAll
End Sub
Public Sub CADtoEXCELXY()
Dim CAD As AutoCAD.AcadApplication
Dim CADDOC As AcadDocument
Dim MYSpace As AcadModelSpace
Dim PLineObj As AcadLWPolyline
Dim LineObj As AcadLine
Dim ArcObj As AcadArc
On Error Resume Next
Set CAD = GetObject(, "AutoCAD.Application")
If Err Then
Dim msg As String
msg = Err.Description + "! 检查CAD图是否已打开"
MsgBox msg
Exit Sub
Err.Clear
End If
CAD.Visible = True
Set CADDOC = CAD.ActiveDocument
Set MYSpace = CADDOC.ModelSpace
Dim MYGetPoints() As Double
Dim Row As Integer, Column As Integer, i As Integer
Dim x As Double, y As Double
ThisWorkbook.Application.WindowState = xlMinimized
CAD.Application.WindowState = acMax
Getstart:
Erase MYGetPoints
ReDim MYGetPoints(2)
MYGetPoints = CADDOC.Utility.GetPoint
Row = Selection.Row
Column = Selection.Column
x = 0: y = 0
x = MYGetPoints(0)
y = MYGetPoints(1)
If x * y = 0 Then GoTo GetOVER
ActiveSheet.Cells.Cells(Row, Column).Value = y
ActiveSheet.Cells.Cells(Row, Column + 1).Value = x
ActiveSheet.Cells.Cells(Row + 1, Column).Select
GoTo Getstart
GetOVER:
CAD.Application.WindowState = acMin
ThisWorkbook.Application.WindowState = xlMaximized
End Sub
Public Function GCJS(AskZH As Double) As Double
Dim Row1 As Integer, Column1 As Integer, Row2 As Integer, column2 As Integer
Dim BpdZH As Double, StZH As Double, StGC As Double, BpdGC As Double, BpdR As Double, ENDZH As Double, EndGC As Double
Dim i As Integer, Gcysds As Integer, Gcdqys As Integer, Pdi1 As Double, Pdi2 As Double, QlR As Double, BpdJ As Double, BpdT As Double, dZH As Double
Gcysds = Worksheets("GCYS").Range("G1")
Gcdqys = Worksheets("GCYS").Range("G2")
If Gcdqys < 1 Then Gcdqys = 1
If Gcdqys > Gcysds Then Gcdqys = Gcysds
Row2 = 6
Row1 = 1: Column1 = 1
i = 0
STGCIF:
Row1 = Row2 + Gcdqys
StZH = Worksheets("GCYS").Cells(Row1, Column1 + 1).Value
StGC = Worksheets("GCYS").Cells(Row1, Column1 + 2).Value
Row1 = Row2 + Gcdqys + 1
BpdZH = Worksheets("GCYS").Cells(Row1, Column1 + 1).Value
BpdGC = Worksheets("GCYS").Cells(Row1, Column1 + 2).Value
BpdR = Worksheets("GCYS").Cells(Row1, Column1 + 3).Value
Pdi1 = (BpdGC - StGC) / (BpdZH - StZH)
Row1 = Row2 + Gcdqys + 2
ENDZH = Worksheets("GCYS").Cells(Row1, Column1 + 1).Value
EndGC = Worksheets("GCYS").Cells(Row1, Column1 + 2).Value
Pdi2 = (EndGC - BpdGC) / (ENDZH - BpdZH)
BpdJ = Pdi1 - Pdi2
BpdT = Abs(BpdR * BpdJ) / 2
QlR = QL(BpdR)
If BpdJ > 0 Then QlR = -QlR
If AskZH > BpdZH - BpdT Then
If AskZH < BpdZH Then
dZH = AskZH - BpdZH + BpdT
GCJS = BpdGC - BpdT * Pdi1 + dZH * Pdi1 + dZH ^ 2 / 2 * QlR
ElseIf AskZH < BpdZH + BpdT Then
dZH = AskZH - BpdZH - BpdT
GCJS = BpdGC + BpdT * Pdi2 + dZH * Pdi2 + dZH ^ 2 / 2 * QlR
ElseIf Gcdqys >= Gcysds Then
If AskZH < ENDZH Then
dZH = AskZH - ENDZH
GCJS = EndGC + dZH * Pdi2
Else
GCJS = 1
End If
Else
Gcdqys = Gcdqys + 1
i = 1
GoTo STGCIF
End If
ElseIf i = 1 Then
dZH = AskZH - StZH
GCJS = StGC + dZH * Pdi1
ElseIf Gcdqys <= 1 Then
If AskZH > StZH Then
dZH = AskZH - StZH
GCJS = StGC + dZH * Pdi1
Else
GCJS = -1
End If
Else
Gcdqys = Gcdqys - 1
GoTo STGCIF
End If
End Function
Public Function FGCJS(AskZH As Variant) As Double
FGCJS = GCJS(CDbl(AskZH))
End Function
Public Function FZBJS(AskZH0 As Variant, AskHXJL0 As Variant, sel0 As Variant) As Double
Dim AskZH As Double, AskHXJL As Double
AskZH = CDbl(AskZH0)
AskHXJL = CDbl(AskHXJL0)
If Worksheets("SET").Cells(3, 2).Value > 0 Then AskZH = DLcl(AskZH)
Dim StartZH As Double, StartN As Double, StartE As Double, StartFWJ As Double, StartQLR As Double, EndQLR As Double, Ength As Double, SubFWJ As Double
Dim Row As Integer, Column As Integer, i As Integer
Dim ysds As Integer
Dim dqys As Integer
Row = 6
Column = 1
ysds = Worksheets("SIMPSYS").Cells(1, 7).Value
dqys = Worksheets("SIMPSYS").Cells(2, 7).Value
For i = 1 To ysds
If AskZH > Worksheets("SIMPSYS").Cells(Row + dqys, Column).Value + Worksheets("SIMPSYS").Cells(Row + dqys, Column + 6).Value Then
If dqys >= ysds Then
XXX = 0
YYY = 0
MsgBox ("请求里程超出要素范围up")
Worksheets("SIMPSYS").Cells(2, 7).Value = ysds
End
End If
dqys = dqys + 1
ElseIf AskZH > Worksheets("SIMPSYS").Cells(Row + dqys, Column).Value Then
Exit For
Else:
dqys = dqys - 1
If dqys < 1 Then
XXX = 0
YYY = 0
MsgBox ("请求里程超出要素范围do")
Worksheets("SIMPSYS").Cells(2, 7).Value = 1
End
End If
End If
Next i
'Worksheets("SIMPSYS").Cells(2, 7).Value = dqys
StartZH = Worksheets("SIMPSYS").Cells(Row + dqys, Column).Value
StartN = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 1).Value
StartE = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 2).Value
StartFWJ = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 3).Value
StartQLR = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 4).Value
EndQLR = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 5).Value
Ength = Worksheets("SIMPSYS").Cells(Row + dqys, Column + 6).Value
'Call SimpsZBJS(StartZH, StartN, StartE, StartFWJ, StartQLR, EndQLR, Ength, AskZH, 0)
Dim K As Double, H As Double, j As Integer, x As Double
Dim a As Double, b As Double
Dim FourN As Double, TwoN As Double, SN As Double
Dim FourE As Double, TwoE As Double, SE As Double
XXX = 0
YYY = 0
K = (EndQLR - StartQLR) / Ength / 2
If step > 10000 Then step = 10000
step = 6000 + step
H = (AskZH - StartZH) / step / 2
a = 0
b = AskZH - StartZH
x = a
FWJ = StartFWJ + StartQLR * b + K * b ^ 2
If FWJ < 0 Then FWJ = FWJ + 2 * π
If FWJ > 2 * π Then FWJ = FWJ - 2 * π
SN = Cos(StartFWJ) + Cos(FWJ)
SE = Sin(StartFWJ) + Sin(FWJ)
For j = 1 To step
x = x + H
SubFWJ = StartFWJ + StartQLR * x + K * x ^ 2
FourN = FourN + Cos(SubFWJ)
FourE = FourE + Sin(SubFWJ)
x = x + H
SubFWJ = StartFWJ + StartQLR * x + K * x ^ 2
TwoN = TwoN + Cos(SubFWJ)
TwoE = TwoE + Sin(SubFWJ)
Next j
TwoN = TwoN - Cos(SubFWJ)
TwoE = TwoE - Sin(SubFWJ)
SN = SN + 4 * FourN + 2 * TwoN
SE = SE + 4 * FourE + 2 * TwoE
XXX = StartN + SN * H / 3
YYY = StartE + SE * H / 3
SubFWJ = FWJ + π / 2
Dim sel As String
sel = CStr(sel0)
If sel = "n" Or sel = "N" Then FZBJS = XXX + Cos(SubFWJ) * AskHXJL
If sel = "e" Or sel = "E" Then FZBJS = YYY + Sin(SubFWJ) * AskHXJL
If sel = "f" Or sel = "F" Then FZBJS = SubFWJkHXJL
End Function