📄 红外线极坐标.frm

📁 饮羽公路测设（glcs）由20多个公路测量、设计、试验和施工组织设计等小软件组成。如《中桩大地坐标》可以计算不等长缓和曲线的中桩和边桩的大地坐标；《缓和曲线反算》可以根据切线长、外距长或缓和曲线长求
💻 FRM
📖 第 1 页 / 共 2 页
字号:
上一页 12
         Width           =   1455
      End
      Begin VB.Label Label3 
         Caption         =   "后视点X坐标＝"
         Height          =   255
         Left            =   120
         TabIndex        =   10
         Top             =   1080
         Width           =   1335
      End
      Begin VB.Label Label2 
         Caption         =   "测点Y坐标 ＝"
         Height          =   255
         Left            =   120
         TabIndex        =   9
         Top             =   720
         Width           =   1215
      End
      Begin VB.Label Label1 
         Caption         =   "测点X坐标 ＝"
         Height          =   255
         Left            =   120
         TabIndex        =   8
         Top             =   360
         Width           =   1215
      End
   End
End
Attribute VB_Name = "frmhwxjzb"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim S As Double



Private Sub Command1_Click()
'计算坐标
        
    On Error GoTo handlerror

    xa = Val(Text1.Text)
    ya = Val(Text2.Text)
    xb = Val(Text3.Text)
    yb = Val(Text4.Text)
    Call fwj(ab, xa, ya, xb, yb)
    xc = Val(Text5.Text)
    yc = Val(Text6.Text)
    Call fwj(ac, xa, ya, xc, yc)
    t = S
    b = ac - ab
    
    r = Abs(b)
    dd = r * 180 / pi
    d1 = Int(dd)
    m = Int((dd - d1) * 60)
    ss = Int(((dd - d1) * 60 - m) * 60)
    d1 = d1 * Sgn(b)

    For i = 1 To VSFlexGrid1.Rows - 1
        If VSFlexGrid1.TextMatrix(i, 0) = "" Then
            Exit For
        End If
    Next i
    VSFlexGrid1.TextMatrix(i, 0) = i
    VSFlexGrid1.TextMatrix(i, 1) = xc
    VSFlexGrid1.TextMatrix(i, 2) = yc
    VSFlexGrid1.TextMatrix(i, 3) = Trim(Str(d1)) + Trim("°") + Trim(Str(m)) + Trim("′") + Trim(Str(ss)) + Trim("″")
    VSFlexGrid1.TextMatrix(i, 4) = Int(t * 1000 + 0.5) / 1000
    VSFlexGrid1.Rows = VSFlexGrid1.Rows + 1
    
    Text5.Text = ""
    Text6.Text = ""
    Text5.SetFocus
    
    Exit Sub
handlerror:
    
End Sub

Private Sub Command2_Click()
'保存

    If rjsfzc = 88 Then
        If FileName = "" Then
            CommonDialog1.CancelError = True
            On Error GoTo Erra
            CommonDialog1.Filter = "text files(*.txt)|*.txt|all files(*.*)|*.*"
            CommonDialog1.ShowSave
            FileName = CommonDialog1.FileName
        End If
        Open FileName For Append As #1
            wjhj = ""
            For i = 0 To VSFlexGrid1.Rows - 1
                If i = 0 Then wjhj = "     " + VSFlexGrid1.TextMatrix(i, 0) + "    " + VSFlexGrid1.TextMatrix(i, 1) + "    " + VSFlexGrid1.TextMatrix(i, 2) + "    " + VSFlexGrid1.TextMatrix(i, 3) + "    " + VSFlexGrid1.TextMatrix(i, 4)
                If i <> 0 Then wjhj = wjhj & vbCrLf & "       " + VSFlexGrid1.TextMatrix(i, 0) + "    " + VSFlexGrid1.TextMatrix(i, 1) + "    " + VSFlexGrid1.TextMatrix(i, 2) + "    " + VSFlexGrid1.TextMatrix(i, 3) + "    " + VSFlexGrid1.TextMatrix(i, 4)
            Next i
            Print #1, ""
            Print #1, "        －－－－初始数据－－－－"
            Print #1, ""
            Print #1, "     测点X坐标  ＝" + Text1.Text
            Print #1, "     测点Y坐标  ＝" + Text2.Text
            Print #1, "     后视点X坐标＝" + Text3.Text
            Print #1, "     后视点Y坐标＝" + Text4.Text
            Print #1, ""
            Print #1, ""
            Print #1, "        －－－－计算数据－－－－"
            Print #1, ""
            Print #1, wjhj
        Close #1
    End If
    
    Exit Sub
Erra:

End Sub

Private Sub Command3_Click()
'打印

    If rjsfzc = 88 Then
        Dim beginpage, endpage, numcopies, j
        CommonDialog1.CancelError = True
        On Error GoTo errorhandler
            CommonDialog1.ShowPrinter
            beginpage = CommonDialog1.FromPage
            endpage = CommonDialog1.ToPage
            numcopies = CommonDialog1.Copies
            For j = 1 To numcopies
                wjhj = ""
                For i = 0 To VSFlexGrid1.Rows - 1
                    If i = 0 Then wjhj = "     " + VSFlexGrid1.TextMatrix(i, 0) + "    " + VSFlexGrid1.TextMatrix(i, 1) + "    " + VSFlexGrid1.TextMatrix(i, 2) + "    " + VSFlexGrid1.TextMatrix(i, 3) + "    " + VSFlexGrid1.TextMatrix(i, 4)
                    If i <> 0 Then wjhj = wjhj & vbCrLf & "       " + VSFlexGrid1.TextMatrix(i, 0) + "    " + VSFlexGrid1.TextMatrix(i, 1) + "    " + VSFlexGrid1.TextMatrix(i, 2) + "    " + VSFlexGrid1.TextMatrix(i, 3) + "    " + VSFlexGrid1.TextMatrix(i, 4)
                Next i
                Printer.Print ""
                Printer.Print "        －－－－初始数据－－－－"
                Printer.Print ""
                Printer.Print "     测点X坐标  ＝" + Text1.Text
                Printer.Print "     测点Y坐标  ＝" + Text2.Text
                Printer.Print "     后视点X坐标＝" + Text3.Text
                Printer.Print "     后视点Y坐标＝" + Text4.Text
                Printer.Print ""
                Printer.Print ""
                Printer.Print "        －－－－计算数据－－－－"
                Printer.Print ""
                Printer.Print wjhj
            Next j
        Printer.EndDoc
    End If
    
    Exit Sub
errorhandler:

End Sub

Private Sub Command4_Click()
'退出
    
    On Error GoTo handlerror
    
    If rjsfzc = 88 And VSFlexGrid1.Rows > 2 Then
        frmMain.Text1 = frmMain.Text1 & vbCrLf & ""
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    《红外线极坐标计算结果》："
        frmMain.Text1 = frmMain.Text1 & vbCrLf & ""
        
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    测点X坐标 ＝" + Text1.Text
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    测点Y坐标 ＝" + Text2.Text
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    后视点X坐标＝" + Text3.Text
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    后视点Y坐标＝" + Text4.Text
        
        For i = 0 To VSFlexGrid1.Rows - 2
            If i = 0 Then frmMain.Text1 = frmMain.Text1 & vbCrLf & "    " + VSFlexGrid1.TextMatrix(i, 0) + "    " + VSFlexGrid1.TextMatrix(i, 1) + "    " + VSFlexGrid1.TextMatrix(i, 2) + "    " + VSFlexGrid1.TextMatrix(i, 3) + " " + VSFlexGrid1.TextMatrix(i, 4)
            wbbb = "    "
            If i <> 0 Then
                For j = 0 To VSFlexGrid1.Cols - 1
                    wbbb = wbbb + VSFlexGrid1.TextMatrix(i, j)
                    If Len(VSFlexGrid1.TextMatrix(i, j)) = 0 Then kgg = "             "
                    If Len(VSFlexGrid1.TextMatrix(i, j)) = 1 Then kgg = "            "
                    If Len(VSFlexGrid1.TextMatrix(i, j)) = 2 Then kgg = "           "
                    If Len(VSFlexGrid1.TextMatrix(i, j)) = 3 Then kgg = "          "
                    If Len(VSFlexGrid1.TextMatrix(i, j)) = 4 Then kgg = "         "
                    If Len(VSFlexGrid1.TextMatrix(i, j)) = 5 Then kgg = "        "
                    If Len(VSFlexGrid1.TextMatrix(i, j)) = 6 Then kgg = "       "
                    If Len(VSFlexGrid1.TextMatrix(i, j)) = 7 Then kgg = "      "
                    If Len(VSFlexGrid1.TextMatrix(i, j)) = 8 Then kgg = "     "
                    If Len(VSFlexGrid1.TextMatrix(i, j)) = 9 Then kgg = "    "
                    If Len(VSFlexGrid1.TextMatrix(i, j)) = 10 Then kgg = "   "
                    If Len(VSFlexGrid1.TextMatrix(i, j)) = 11 Then kgg = "  "
                    If Len(VSFlexGrid1.TextMatrix(i, j)) = 12 Then kgg = " "
                    If Len(VSFlexGrid1.TextMatrix(i, j)) = 13 Then kgg = ""
                    wbbb = wbbb + kgg
                Next j
            End If
            frmMain.Text1 = frmMain.Text1 & vbCrLf & wbbb
        Next i
        
        
        frmMain.Text1 = frmMain.Text1 & vbCrLf & "    --------------------------------------"
    End If
    
    Unload Me
    
    Exit Sub
handlerror:

End Sub

Private Sub Form_DblClick()
   xianshi = MsgBox("欢迎你使用本程序，有问题请联系我" & vbCrLf & "电子邮箱：shimf@mail.nbptt.zj.cn", vbInformation, "提示")
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
'Esc键退出，VbEscape可以用27代替
    On Error GoTo handlerror

    If KeyAscii = 27 Then
        Unload Me
    End If
    
    Exit Sub
handlerror:

End Sub

Private Sub Form_Load()
'启动

    On Error GoTo handlerror
    
    Text1.Text = ""
    Text2.Text = ""
    Text3.Text = ""
    Text4.Text = ""
    Text5.Text = ""
    Text6.Text = ""
    
    VSFlexGrid1.ColWidth(0) = 440
    VSFlexGrid1.ColWidth(1) = 1170
    VSFlexGrid1.ColWidth(2) = 1170
    VSFlexGrid1.ColWidth(3) = 1760
    VSFlexGrid1.ColWidth(4) = 1360
    VSFlexGrid1.TextMatrix(0, 0) = "序号"
    VSFlexGrid1.TextMatrix(0, 1) = "待放点X坐标"
    VSFlexGrid1.TextMatrix(0, 2) = "待放点Y坐标"
    VSFlexGrid1.TextMatrix(0, 3) = "待放点方向(°′″)"
    VSFlexGrid1.TextMatrix(0, 4) = "待放点距离(m)"
    
    VSFlexGrid1.ColAlignment(0) = flexAlignCenterCenter
    VSFlexGrid1.ColAlignment(1) = flexAlignCenterCenter
    VSFlexGrid1.ColAlignment(2) = flexAlignCenterCenter
    VSFlexGrid1.ColAlignment(3) = flexAlignCenterCenter
    VSFlexGrid1.ColAlignment(4) = flexAlignCenterCenter
    
    Exit Sub
handlerror:
        
End Sub

Public Sub dh(rad, dms)
'度分秒化弧度子程序
    jd = Abs(dms)
    d = Int(jd)
    m = Int(jd * 100) - d * 100
    S = jd * 10000 - d * 10000 - m * 100
    rad = d + m / 60 + S / 60 / 60
    rad = rad * pi / 180
    rad = rad * Sgn(dms)
End Sub

Public Sub fwj(e, x1, y1, x2, y2)
'求方位角子程序
    x3 = x2 - x1
    y3 = y2 - y1
    S = Sqr(x3 * x3 + y3 * y3)
    If x3 = 0 And y3 > 0 Then e = pi / 2: Exit Sub
    If x3 = 0 And y3 < 0 Then e = pi * 1.5: Exit Sub
    a = Atn(y3 / x3)
    a = Abs(a)
    If x3 >= 0 And y3 >= 0 Then e = a
    If x3 < 0 And y3 >= 0 Then e = pi - a
    If x3 <= 0 And y3 <= 0 Then e = pi + a
    If x3 >= 0 And y3 < 0 Then e = 2 * pi - a
End Sub

Public Sub hd(dms, rad)
'弧度化度分秒
    r = Abs(rad)
    dd = r * 180 / pi
    d1 = Int(dd)
    m = Int((dd - d1) * 60)
    ss = Int(((dd - d1) * 60 - m) * 60)
    dms = d1 + m / 100 + ss / 10000: dms = dms * Sgn(rad)
End Sub
上一页 12
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -