放线1.frm

反算坐标 求得距离及方位角

VERSION 5.00
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "宗地测量数据录入程序"
   ClientHeight    =   4905
   ClientLeft      =   6120
   ClientTop       =   3105
   ClientWidth     =   5790
   Icon            =   "放线1.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   MouseIcon       =   "放线1.frx":030A
   ScaleHeight     =   4905
   ScaleWidth      =   5790
   Begin VB.CommandButton Command3 
      Caption         =   "退 出"
      BeginProperty Font 
         Name            =   "黑体"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   735
      Left            =   3600
      MaskColor       =   &H00FFFFFF&
      TabIndex        =   4
      Top             =   2880
      Width           =   1215
   End
   Begin VB.CommandButton Command2 
      Caption         =   "支 点"
      BeginProperty Font 
         Name            =   "黑体"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   735
      Left            =   1920
      TabIndex        =   3
      Top             =   2880
      Width           =   1335
   End
   Begin VB.CommandButton Command1 
      Caption         =   "放 线"
      BeginProperty Font 
         Name            =   "黑体"
         Size            =   14.25
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   735
      Left            =   360
      TabIndex        =   2
      Top             =   2880
      Width           =   1215
   End
   Begin VB.Label Label1 
      Caption         =   "坐标放线程序"
      BeginProperty Font 
         Name            =   "隶书"
         Size            =   21.75
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   -1  'True
         Strikethrough   =   0   'False
      EndProperty
      Height          =   495
      Left            =   1200
      TabIndex        =   1
      Top             =   360
      Width           =   3135
   End
   Begin VB.Line Line3 
      X1              =   4680
      X2              =   4680
      Y1              =   240
      Y2              =   960
   End
   Begin VB.Line Line1 
      X1              =   720
      X2              =   4680
      Y1              =   960
      Y2              =   960
   End
   Begin VB.Line Line4 
      DrawMode        =   16  'Merge Pen
      X1              =   720
      X2              =   720
      Y1              =   240
      Y2              =   960
   End
   Begin VB.Line Line2 
      DrawMode        =   16  'Merge Pen
      X1              =   720
      X2              =   4680
      Y1              =   240
      Y2              =   240
   End
   Begin VB.Label Label2 
      Caption         =   "青海省第二测绘院"
      BeginProperty Font 
         Name            =   "楷体_GB2312"
         Size            =   12
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   255
      Left            =   3240
      MouseIcon       =   "放线1.frx":045C
      TabIndex        =   0
      Top             =   4200
      Width           =   2175
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public App_Path, savefile, Wzspath As String

Private Sub Command1_Click()
   On Error Resume Next
    App_Path = App.Path
    If Right(App_Path, 1) <> "\" Then
      App_Path = App_Path + "\"
    End If
   CommonDialog1.CancelError = True
   CommonDialog1.Filter = "观测数据（*.txt）|*.txt|所有文件（*.*）|*.*"
   CommonDialog1.InitDir = App_Path
   CommonDialog1.ShowSave
   If Err.Number = 32755 Then Exit Sub
   Text1.Text = CommonDialog1.FileName
End Sub

Private Sub Command2_Click()
savefile = Trim(Text1.Text)
 If Left(savefile, 2) = "首先" Then
  MsgBox "请首先输入文件名", 0, "错误"
  Else
   Open savefile For Append As #1
   Load Form2
   Form2.Show
 End If
End Sub

Private Sub Command4_Click()
savefile = Trim(Text1.Text)
If Left(savefile, 2) = "首先" Then
  MsgBox "请首先输入文件名", 0, "错误"
  Else
   Open savefile For Append As #1
   Load Form4
   Form4.Show
 End If
End Sub

Private Sub Command5_Click()
  On Error GoTo whenerror
  Dim errmsg As String
  Dim retvalue As Integer
 '全局变量
   Dim PI As Double
   Dim Fwj, Gul, WWWwww As Single
   PI = 3.14159265358979
'设站变量
   Dim Csbm, Cgdm, Czd, Dxd As String
   Dim CgX, CgY As String
   Dim Xdx, Ydx, Xcz, Wcnm, WWw As Single
   Dim Pdh1, Pdh2 As Integer
'支站和碎部变量
   Dim Zzdh, Wzs, Wls, Dxh As String
   Dim Spj, Pj, Xzz, Yzz, Xsb, Ysb, WWww As Single
   
  savefile = Trim(Text1.Text)
   If Left(savefile, 2) = "首先" Then
    MsgBox "请首先输入文件名", 0, "错误"
     Else
      Open savefile For Input As #1
      
'对文件进行操作
    Open "c:\wzs.txt" For Output As #3
    Do While Not EOF(1)
     Input #1, Csbm
     Select Case Trim(Csbm)
'设站
     Case Is = "$1"
      Pdh1 = 0: Pdh2 = 0
      Input #1, Czd, Dxd, Gul
       Open App_Path + "kz.cg" For Input As #2
         Do While Not EOF(2)
           Input #2, Cgdm, CgX, CgY
           If Trim(Cgdm) = Trim(Dxd) Then
             Xdx = Trim(CgX): Ydx = Trim(CgY)
             Pdh2 = Pdh2 + 1
           End If
           If Trim(Cgdm) = Trim(Czd) Then
             Xcz = Trim(CgX): Wcnm = Trim(CgY)
             Pdh1 = Pdh1 + 1
           End If
           
         Loop
       Close #2
       If Pdh1 > 1 Then MsgBox "程序认为KZ.CG里已知点：" + Czd + "的坐标重复，请核对！", 16, "碎部计算": Exit Sub
       If Pdh2 > 1 Then MsgBox "程序认为KZ.CG里已知点：" + Dxd + "的坐标重复，请核对！", 16, "碎部计算": Exit Sub
       If Pdh1 < 1 Then MsgBox "程序认为KZ.CG里缺少已知点：" + Czd + "的坐标，请核对！", 16, "碎部计算": Exit Sub
       If Pdh2 < 1 Then MsgBox "程序认为KZ.CG里缺少已知点：" + Dxd + "的坐标，请核对！", 16, "碎部计算": Exit Sub
       If Abs(Xcz - Xdx) < 0.00001 Then
          Fwj = 90
         Else
          Fwj = Atn((Ydx - Wcnm) / (Xdx - Xcz)) * 180 / PI
          If Fwj < 0 Then Fwj = Fwj + 180
       End If
       If Wcnm > Ydx Then Fwj = Fwj + 180
       If Fwj >= 360 Then Fwj = Fwj - 360
       Print #3, Trim(Czd); ","; Str(Xcz); ","; Str(Wcnm)
       Print #3, Trim(Dxd); ","; Str(Xdx); ","; Str(Ydx)
       
       
'支站
     Case Is = "$2"
      Input #1, Zzdh, Wzs, Wls
        Spj = Jdtoxs(Trim(Wzs)) - Jdtoxs(Trim(Gul))
        Pj = Trim(Wls)
        If Spj < 0 Then Spj = Spj + 360
        Xzz = Xcz + Pj * Cos((Fwj + Spj) * PI / 180)
        Yzz = Wcnm + Pj * Sin((Fwj + Spj) * PI / 180)
    Open App_Path + "kz.cg" For Append As #2
     Print #2, Trim(Zzdh); ","; Str(Int(Xzz * 1000) / 1000); ","; Str(Int(Yzz * 1000) / 1000)
    Close #2
    Print #3, Trim(Zzdh); ","; Str(Int(Xzz * 1000) / 1000); ","; Str(Int(Yzz * 1000) / 1000)
'碎部计算
     Case Is = "$3"
       Input #1, Dxh, Wzs, Wls
        Spj = Jdtoxs(Trim(Wzs)) - Jdtoxs(Trim(Gul))
        Pj = Trim(Wls)
        If Spj < 0 Then Spj = Spj + 360
        Xsb = Xcz + Pj * Cos((Fwj + Spj) * PI / 180)
        Ysb = Wcnm + Pj * Sin((Fwj + Spj) * PI / 180)
        Print #3, Trim(Dxh); ","; Str(Int(Xsb * 1000) / 1000); ","; Str(Int(Ysb * 1000) / 1000)
   End Select
 Loop
 Close
 
'因为土地局对CAD可能不是太熟悉，所以直接生成文件。
'还可以用LISP语言编制一个展点的程序
 '转换为DXF文件
    Dim DXFfile, Wdh As String
    Dim Gs, Xh, i As Integer
    Dim xcg, ycg, NQSB As Single
    Xh = 31
    Gs = Len(savefile)
    DXFfile = Mid(savefile, 1, Gs - 4) + ".dxf"
       Open "C:\WZS.TXT" For Input As #1
        Open DXFfile For Output As #2
         Print #2, "  0"
         Print #2, "SECTION"
         Print #2, "  2"
         Print #2, "ENTITIES"
      Do While Not EOF(1)
       Input #1, Wdh, xcg, ycg
         Xh = Xh + 1
        Print #2, "  0"
        Print #2, "POINT"
        Print #2, "  5"
        Print #2, Spc(1); Hex(Xh)
        Print #2, "100"
        Print #2, "AcDbEntity"
        Print #2, "  8"
        Print #2, "0"
        Print #2, "100"
        Print #2, "AcDbPoint"
        Print #2, " 10"
        Print #2, Trim(ycg)
        Print #2, " 20"
        Print #2, Trim(xcg)
        Print #2, " 30"
        Print #2, "0.0"
        Print #2, "  0"
        Print #2, "MTEXT"
        Print #2, "  5"
        Print #2, "126"
        Print #2, "100"
        Print #2, "AcDbEntity"
        Print #2, "  8"
        Print #2, "0"
        Print #2, "100"
        Print #2, "AcDbMText"
        Print #2, " 10"
        Print #2, Trim(ycg + 0.4)
        Print #2, " 20"
        Print #2, Trim(xcg + 0.4)
        Print #2, " 30"
        Print #2, "0.0"
        Print #2, " 40"
        Print #2, "0.5"
        Print #2, " 41"
        Print #2, "0.5"
        Print #2, " 71"
        Print #2, "     1"
        Print #2, " 72"
        Print #2, "     5"
        Print #2, "  1"
        Print #2, Wdh
    Loop
      Print #2, "  0"
      Print #2, "ENDSEC"
      Print #2, "  0"
      Print #2, "EOF"
Close

  MsgBox "数据转换完毕!", 0, "数据转换"
 End If
    Exit Sub
whenerror:
    errmsg = "错误号:" & Err.Number & Chr(13) & (10)
    errmsg = errmsg & "错误描述:" & Err.Description
    retvalue = MsgBox(errmsg, 277, Err.Source)
    If retvalue = 4 Then
       Resume 0
     ElseIf retvalue = 3 Then Exit Sub
    End If
End Sub

Private Sub Command3_Click()
End
End Sub