xjjjs.frm

用于公路、轻轨及铁路双线线间距工程计算的源程序。

    Case 4
    Call l2_xyzb4(qdlc2, zhlc2, jslc2, a2, r2, s2, w2, t2, b2, x2, y2)
    Case 5
    Call l2_xyzb5(qdlc2, zhlc2, jslc2, a2, r2, s2, w2, t2, b2, x2, y2)
   End Select
    If Abs(b2) > pi / 2 Then cs = (-1) * zsds1
    If Abs(b2) = pi / 2 Then cs = Sgn(b2) * zsds1
    If Abs(b2) < pi / 2 Then cs = 1 * zsds1
  Do
    Call jisuan_fdzl(zsds1, qdlc1, zhlc1, jslc1, s1, w1, fd1)
   Select Case fd1
    Case 1
    Call l1_xyzb1(qdlc1, jslc1, bpxjd, xjj, b1, x1, y1)
    Case 2
    Call l1_xyzb2(qdlc1, zhlc1, jslc1, bpxjd, xjj, a1, r1, s1, b1, x1, y1)
    Case 3
    Call l1_xyzb3(qdlc1, zhlc1, jslc1, bpxjd, xjj, a1, r1, s1, m1, p1, q1, b1, x1, y1)
    Case 4
    Call l1_xyzb4(qdlc1, zhlc1, jslc1, bpxjd, xjj, a1, r1, s1, w1, t1, b1, x1, y1)
    Case 5
    Call l1_xyzb5(qdlc1, zhlc1, jslc1, bpxjd, xjj, a1, r1, s1, w1, t1, b1, x1, y1)
   End Select
   If Abs(b2) <> pi / 2 Then
    y0 = (x1 - x2) * Tan(pi - b2) + y2
     
    'dd为Ⅰ线计算点(x2,y2)到Ⅱ线的法线(该法线过Ⅱ线计算里程点)的垂直距离
    dd = Abs(Tan(pi - b2) * x1 - y1 - Tan(pi - b2) * x2 + y2) / Sqr(Tan(pi - b2) ^ 2 + 1)
     
    If dd >= jd Then
     jslc1 = jslc1 + dd * Sgn(y0 - y1) * cs
    Else
     Exit Do
    End If
   Else
    x0 = x2
    dd = Abs(x2 - x1)
    If dd >= jd Then
     jslc1 = jslc1 + dd * Sgn(x0 - x1) * cs
    Else
     Exit Do
    End If
   End If
  Loop
  
End Select

   jsxjj = Sqr((x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2))
   
   Call zhijiao_dadi(x1, y1, af0, n0, e0, n1, e1)
   Call zhijiao_dadi(x2, y2, af0, n0, e0, n2, e2)
   
   
   Text8.Text = Format$(jslc1, "0.000")
   Text9.Text = Format$(jslc2, "0.000")
   Text10.Text = Format$(jsxjj, "0.000")
   Text15.Text = Format$(n1, "0.0000")
   Text16.Text = Format$(e1, "0.0000")
   Text17.Text = Format$(n2, "0.0000")
   Text18.Text = Format$(e2, "0.0000")
   
 If cp = 1 Then
  
  
  H_af0 = Val(Text11.Text)
  H_bpxjd = Val(Text7.Text)
  
  
  H_a1 = Val(Text3(0).Text)
  H_r1 = Val(Text4(0).Text)
  H_s1 = Val(Text5(0).Text)
  H_t1 = Format(t1, "0.00")
  H_w1 = Format(w1, "0.00")
  
  H_a2 = Val(Text3(1).Text)
  H_r2 = Val(Text4(1).Text)
  H_s2 = Val(Text5(1).Text)
  H_t2 = Format(t2, "0.00")
  H_w2 = Format(w2, "0.00")
  
  H_cz(0) = "Ⅱ"
  H_qdlc1 = Val(Text1(0).Text)
  H_qdlc2 = Val(Text1(1).Text)
  H_n2(0) = Val(Text12.Text)
  H_e2(0) = Val(Text13.Text)
  H_xjj = Val(Text6.Text)
  
  Select Case zsds1
   Case -1
    H_zhlc1 = Format(zhlc1 - w1, "0.00")
    H_hzlc1 = Format(zhlc1, "0.00")
   Case 1
    H_zhlc1 = Format(zhlc1, "0.00")
    H_hzlc1 = Format(zhlc1 + w1, "0.00")
  End Select
  
  Select Case zsds2
   Case -1
    H_zhlc2 = Format(zhlc2 - w2, "0.00")
    H_hzlc2 = Format(zhlc2, "0.00")
   Case 1
    H_zhlc2 = Format(zhlc2, "0.00")
    H_hzlc2 = Format(zhlc2 + w2, "0.00")
  End Select
 
  
   intvar = intvar + 1
   
   Select Case cz
    Case 1
     H_cz(intvar) = "Ⅰ"
    Case 2
     H_cz(intvar) = "Ⅱ"
   End Select
   
   H_jslc1(intvar) = Format(jslc1, "0.00")
   H_n1(intvar) = Format(n1, "0.000")
   H_e1(intvar) = Format(e1, "0.000")
   H_jslc2(intvar) = Format(jslc2, "0.00")
   H_n2(intvar) = Format(n2, "0.000")
   H_e2(intvar) = Format(e2, "0.000")
   H_jsxjj(intvar) = Format(jsxjj, "0.00")
 End If
 
 Exit Sub

ErrHandler:
 
 MsgBox "在计算过程当中发现:" & vbCrLf & vbCrLf & "“" & Str(Err.number) & "#错误---" & Err.Description _
         & " ”" & vbCrLf & vbCrLf & "请仔细检查原始数据!", vbOKOnly + vbExclamation, "敬请注意"

End Sub

 


 
  
'完成
Private Sub Command2_Click()
 Dim ExcelObj As Object
 Dim i As Integer, j As Integer
 Dim page As Integer
 Dim mm(50) As Integer, nn(50) As Integer
 
 
 
If cp = 1 Then
 
 
   Call ExcelOpen(ExcelObj)
 
  
 With ExcelObj
 
 
    Call MHpage(intvar, 21, 26, page, mm(), nn())
   
    If page = 1 Then
     .Workbooks.Add template:=App.Path & "\xjj-1.xlt"
    Else
     .Workbooks.Add template:=App.Path & "\xjj-2.xlt"
    End If
    
   '.activeworkbook.Activate
   '  If .workbooks.Count = 0 Then
     'Debug.Print "添加一个新的工作表"
     .ActiveWorkbook.SaveAs FileName:=CommonDialog1.FileName, addtomru:=True
     '将要打开的工作簿加进Excel的最近使用文件清单中
   ' End If
     .Workbooks.Open FileName:=CommonDialog1.FileName, _
      updatelinks:=3, ReadOnly:=False, addtomru:=True
     '工作簿的外部链接和远程引用都更新
     '不以只读方式打开工作簿
     '将要打开的工作簿加进Excel的最近使用文件清单中

    .Visible = True     '显示已经生成或访问的Excel对象
    
    If page = 1 Then
     .Sheets(1).Name = "第1页"
    Else
     .Sheets(1).Name = "第1页"
     .Sheets(2).Name = "第2页"
    End If
    
   
   With .ActiveWorkbook
    
    For i = 1 To page
     If i >= 3 Then
       .Sheets("第2页").Copy after:=.Sheets(i - 1)
       .Sheets(i).Name = "第" & Trim(Str(i)) & "页"
     End If
    Next i
   
   
   
   
    For i = 1 To page
                       
     With .Sheets(i)
         .Activate
         .Cells(2, 8).Value = "第" & Trim(Str(i)) & "页"
         .Cells(2, 9).Value = "共" & Trim(Str(page)) & "页"
         .Cells(31, 8).Value = Year(Now) & "/" & Month(Now) & "/" & Day(Now)
   
     Select Case i
      Case 1
       .Cells(5, 1).Value = " D0=" & Str(H_xjj) & "   A0=" & Str(H_bpxjd) & "     H0=" & Str(H_af0)
       .Cells(6, 1).Value = " a1=" & Str(H_a1) & "   r1=" & Str(H_r1) & "     s1=" & Str(H_s1) & "     t1=" & Str(H_t1) & "   w1=" & Str(H_w1)
       .Cells(7, 1).Value = " QD1=" & Str(H_qdlc1) & "   ZH1=" & Str(H_zhlc1) & "    HZ1=" & Str(H_hzlc1)
       .Cells(8, 1).Value = " a2=" & Str(H_a2) & "   r2=" & Str(H_r2) & "     s2=" & Str(H_s2) & "     t2=" & Str(H_t2) & "   w2=" & Str(H_w2)
       .Cells(9, 1).Value = " QD2=" & Str(H_qdlc2) & "   ZH2=" & Str(H_zhlc2) & "    HZ2=" & Str(H_hzlc2)
       For j = mm(i) To nn(i)
        .Cells(j - mm(i) + 10, 1).Value = H_cz(j)
        .Cells(j - mm(i) + 10, 2).Value = H_jslc1(j)
        .Cells(j - mm(i) + 10, 3).Value = H_n1(j)
        .Cells(j - mm(i) + 10, 4).Value = H_e1(j)
        .Cells(j - mm(i) + 10, 5).Value = H_jslc2(j)
        .Cells(j - mm(i) + 10, 6).Value = H_n2(j)
        .Cells(j - mm(i) + 10, 7).Value = H_e2(j)
        .Cells(j - mm(i) + 10, 8).Value = H_jsxjj(j)
       Next j
       
      Case Else
       For j = mm(i) To nn(i)
        .Cells(j - mm(i) + 5, 1).Value = H_cz(j)
        .Cells(j - mm(i) + 5, 2).Value = H_jslc1(j)
        .Cells(j - mm(i) + 5, 3).Value = H_n1(j)
        .Cells(j - mm(i) + 5, 4).Value = H_e1(j)
        .Cells(j - mm(i) + 5, 5).Value = H_jslc2(j)
        .Cells(j - mm(i) + 5, 6).Value = H_n2(j)
        .Cells(j - mm(i) + 5, 7).Value = H_e2(j)
        .Cells(j - mm(i) + 5, 8).Value = H_jsxjj(j)
       Next j
      
     End Select
     
    End With
   Next i
      .Save
     ' .Close savechanges:=True
     '关闭工作簿，并保存工作簿的改变内容
   End With
   ' .Dialogs(xlDialogSaveAs).Show arg1:=App.Path & "\xjj.xls"
    
    '.quit    '关闭Excel应用程序或Excel对象
    
  End With
  
    
    Set ExcelObj = Nothing    '关闭后释放内存
 End If
 
End Sub
 

'退出
Private Sub Command3_Click()

   Call MHexit(Me)
   Unload Me
   
End Sub

'初始设置
Private Sub Form_Load()


  Me.Icon = LoadPicture(App.Path & "\FlagScot.ico")
  Me.Left = (Screen.Width - Me.Width) / 2
  Me.Top = (Screen.Height - Me.Height) / 2
  
  
  
  
  
  Combo1.AddItem "0.0005"
  Combo1.AddItem "0.001"
  Combo1.AddItem "0.002"
  Combo1.AddItem "0.003"
  Combo1.AddItem "0.004"
  Combo1.AddItem "0.005"
  Combo1.Text = Combo1.List(1)
  Text10.Enabled = False
  Text15.Enabled = False
  Text16.Enabled = False
  Text17.Enabled = False
  Text18.Enabled = False
  
  Option2(0).Value = True
  Option3(2).Value = True
  Option4(2).Value = True
 ' Check1.Value = 0
  intvar = 0
  Timer1.Interval = 300
  
  Me.Caption = Space(40) & "欢迎使用《公路线间距计算软件》.........杨红杰 "
  Text14.Text = " ● 不管两线的位置、方向等等，我们把其中任一条线定义为Ⅰ线，另一条定义为Ⅱ线。当定义后，下面就以定义的为准了。" & vbCrLf & _
" ● 【计算结果存盘】我们可以把计算结果保存在*.txt或*.dat的文件中，该过程必须在计算前完成。当然也可不保存。" & vbCrLf & _
" ● 【计算精度参数】就是非基准线计算点的最终坐标到基准线的法线（该法线过基准线的计算里程点）的垂直距离。即非基准线的最终计" & _
"算点与该点的真值的差值。该值默认为0.0005，其精度已相当高了，可不用再去管它。" & vbCrLf & _
" ● 【计算起点两线线间距】两线计算起点必须在两直线段内，该处线间距始终是以Ⅱ线为基准的线间距，即该线间距是垂直Ⅱ线的线" & _
"间距（切记）。在计算起点处Ⅰ线在Ⅱ线的上方时该线间距为正值、下方时为负值（不管其它，只管上下），在一起时为零。" & vbCrLf & _
" ● 【计算起点不平行角度】是指Ⅰ线相对于Ⅱ线上、下（不管其它，只管上下）偏移的角度，上偏为正、下偏为负，平行时为零。" & vbCrLf & _
" ● 【计算起点方位、坐标】计算起点方位为Ⅱ线切线由计算起点到计算点方向的方位。计算起点坐标为Ⅱ线计算起点处的坐标。该方位、坐" & _
"标也可不输入，此时该值默认为零。如果该方位、坐标输入大地坐标系的方位、坐标，那么〈计算结果显示〉一栏列出的坐标就为大地坐标了。该坐标可以帮助我们画图时参考。" & vbCrLf & _
" ● 因为该线间距计算是先算出基准线计算里程点的坐标，再算出过该点的法线与另一条线交叉点的坐标，最后再根据两点坐标反算线间距，所以根据〈计" & _
"算结果显示〉一栏列出的坐标可校验线间距计算是否正确（当然一般情况下计算是正确的），并可根据两点坐标（x，y）的位置来判断线间距的正负。" & vbCrLf & _
" ● 【里程正（倒）算】是指计算里程（或弯道头尾里程）与计算起点里程相比，里程增加（减小）。" & vbCrLf & _
" ● 里程正算时，弯道头尾里程、计算里程必须大于等于起点里程。里程倒算时，弯道头尾里程、计算里程必须小于等于起点" & _
"里程。如果输入错误，计算时会出现提示对话框提示重新输入，并使光标停留在该文本框处。" & vbCrLf & _
" ● 【曲线偏角】曲线偏角分左、右偏，由计算起点到计算点方向来判断左、右偏，左偏为正、右偏为负。" & vbCrLf & _
" ● 【以Ⅰ（Ⅱ）线为基准】是指该线间距是过Ⅰ（Ⅱ）线计算里程点处的法线与两线交叉点间的距离，即该线间距是垂直Ⅰ（Ⅱ）线的线间距。在计算过程中基准线可以转换。" & vbCrLf & _
" ● 线间距以那条线为基准，那条线计算里程必须输入正确，该文本框以淡黄色背景强调，另一条线计算里程不需要输入，该框不响应用户操作。" & vbCrLf & _
" ● 【完成】键的作用是当我们计算完一段线间距（即该计算过程只有计算里程、基准线不断改变，其它参数不变）后，按一下【完成】键来关闭打开的文件，可在不" & _
"退出的情况下，重新打开另一文件，改变计算参数继续另一曲线线间距的计算。主要是因为曲线参数等改变后，必须重新打开另一文件来保存计算结果。" & vbCrLf & _
" ● 通过以上的介绍，我们可以看出：只要知道两线计算起点（必须在两直线段内）的关系（线间距、不平行角度）及计算起点、弯道头尾里程，我们就可以计算该线间距了。如果" & _
"已知的是其它条件，我们可以通过简单的计算进行转换。根据两线曲线偏角的正负我们可以计算出各种类型（同向、开口、交叉等等）的线间距。只要弯道头尾里程的输入值在计算" & _
"范围之外，我们还可以计算出直线与直线、直线与曲线的线间距。我们还可以计算出计算终点的线间距、计算里程，与计算起点里程相比较可得出两曲线的长、短链来。" & vbCrLf & _
" ● 另外为了输入快捷，该软件设置了【Tab】及【Enter】键功能，即输入完一文本框后按【Tab】或【Enter】键就立即进入下一文本框等待输入。"

 '  " ● dd为非基准线计算点到基准线的法线（该法线过基准线的计算里程点）的垂直距离。非基准线" & _
 '  "计算里程就是根据这个距离不断递增或递减这个距离，直到这个距离小于计算精度为止。" & _
 '  " ● 我们建立的坐标系是以Ⅱ线切线方向为Y坐标值 、Ⅱ线计算起点处的法线方向为X坐标值 、" & _
 '  "Ⅱ线计算起点为坐标原点的坐标系。该坐标系与大地坐标系一致，都为左手系。" & vbCrLf &


 'Call ResizeInit(Me)  '在程序装入时必须加入


End Sub



Private Sub Form_Resize()





   'Call ResizeInit(Me)  '在程序装入时必须加入



  ' Call ResizeForm(Me)  '确保窗体改变时控件随之改变



End Sub

'基准线选择按钮
Private Sub Option2_Click(Index As Integer)
  Select Case Index
   Case 0
    Text8.Enabled = True
    Text8.BackColor = &HC0E0FF
    Text9.Enabled = False
    Text9.BackColor = &HFFFFFF
   Case 1
    Text9.Enabled = True
    Text9.BackColor = &HC0E0FF
    Text8.Enabled = False
    Text8.BackColor = &HFFFFFF
  End Select
    cz = Index + 1
E