frmmain.frm

饮羽公路测设（glcs） 由20多个公路测量、设计、试验和施工组织设计等小软件组成。如《中桩大地坐标》可以计算不等长缓和曲线的中桩和边桩的大地坐标；《缓和曲线反算》可以根据切线长、外距长或缓和曲线长求

      Begin VB.Menu sy12 
         Caption         =   "-"
      End
      Begin VB.Menu plfbzft 
         Caption         =   "频率分布直方图"
      End
      Begin VB.Menu yyqxnh 
         Caption         =   "一元曲线拟合"
      End
      Begin VB.Menu dcxnh 
         Caption         =   "多次项拟合"
      End
      Begin VB.Menu menuysdhd 
         Caption         =   "压实度厚度评定"
      End
   End
   Begin VB.Menu menutool 
      Caption         =   "工具(&T)"
      Begin VB.Menu dbxmj 
         Caption         =   "多边形面积"
      End
      Begin VB.Menu sy35 
         Caption         =   "-"
      End
      Begin VB.Menu menuxxfc 
         Caption         =   "线性方程"
      End
      Begin VB.Menu menulxxjd 
         Caption         =   "两线相交"
      End
      Begin VB.Menu sy36 
         Caption         =   "-"
      End
      Begin VB.Menu menucygsh 
         Caption         =   "常用公式"
      End
      Begin VB.Menu sy30 
         Caption         =   "-"
      End
      Begin VB.Menu menujsq 
         Caption         =   "计算器"
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助(&H)"
      Begin VB.Menu mnuHlp 
         Caption         =   "帮助(&S)..."
      End
      Begin VB.Menu mnuHelpBar0 
         Caption         =   "-"
      End
      Begin VB.Menu rjzhuy 
         Caption         =   "软件主页"
      End
      Begin VB.Menu mnuHelpAbout 
         Caption         =   "关于本程序(&A) "
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal Hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal Hkey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long

      ' Return codes from Registration functions.
      Const ERROR_SUCCESS = 0&
      Const ERROR_BADDB = 1&
      Const ERROR_BADKEY = 2&
      Const ERROR_CANTOPEN = 3&
      Const ERROR_CANTREAD = 4&
      Const ERROR_CANTWRITE = 5&
      Const ERROR_OUTOFMEMORY = 6&
      Const ERROR_INVALID_PARAMETER = 7&
      Const ERROR_ACCESS_DENIED = 8&

      Private Const HKEY_CLASSES_ROOT = &H80000000
      Private Const MAX_PATH = 260&
      Private Const REG_SZ = 1
      
      Private Const SW_SHOWNORMAL = 1


Private Sub bklcwc_Click()
'贝克曼梁测弯沉

    frmbklcwc.Show vbModal, Me
    
End Sub

Private Sub dakai_Click()
'打开文件
    
    Dim wjstr As String

    If Trim$(Text1.Text) <> "" And bcwjpd = 1 Then
        xianshi = MsgBox("请问，是否要保存数据文件？", vbYesNoCancel + vbExclamation, "问题提示")
        If xianshi = 6 Then      '是
            Call mnuFileSaveAs_Click
            Text1.Text = ""
        End If
        If xianshi = 7 Then     '否
            Text1.Text = ""
        End If
        If xianshi = 2 Then     '取消
            Exit Sub
        End If
    End If
     
    CommonDialog1.CancelError = True
    On Error GoTo handlerror
    
    CommonDialog1.InitDir = App.Path & "\"
    CommonDialog1.Filter = "公路测设(*.gcs)|*.gcs|所有文件(*.*)|*.*"
    CommonDialog1.ShowOpen
    FileName = CommonDialog1.FileName
    wjlj = FileName
    
    wjstr = ""
    
    Open FileName For Input As #1
        Do Until EOF(1)
            Line Input #1, wenb
            wjstr = wjstr & vbCrLf & wenb
        Loop
    Close #1
    
    Text1.Text = wjstr
    
    frmMain.Caption = "饮羽公路测设" + "    " + wjlj
    
    bcwjpd = 0
    
    Exit Sub
handlerror:

End Sub

Private Sub dbxmj_Click()
'多边形面积

    frmdbxmj.Show vbModal, Me

End Sub

Private Sub dcxnh_Click()
'多次项拟合

    frmdcnh.Show vbModal, Me

End Sub

Private Sub fdcxfs_Click()
'非对称型平曲线敷设

    frmfdcfs.Show vbModal, Me
    
End Sub

Private Sub Form_Load()
'启动主窗体

 Dim sKeyName1, sKeyName2 As String 'Holds Key Name in registry.
          Dim sKeyValue As String 'Holds Key Value in registry.
          Dim ret1&, ret2&          'Holds error status if any from API calls.
          Dim lphKey&       'Holds created key handle from RegCreateKey.

    On Error GoTo handlerror
    
      'This creates a Root entry called "glcs files".
          sKeyName1 = "glcs files"
          sKeyName2 = "glcs files"
          sKeyValue = "glcs Application"
          
          ret1& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName1, lphKey&)
          ret1& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)
          ret2& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName2, lphKey&)
          ret2& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)
      
      'This creates a Root entry called .BAR associated with "MyApp".
          sKeyName1 = ".gcs"
          sKeyName2 = ".gcs"
          sKeyValue = "glcs document"
          
          ret1& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName1, lphKey&)
          ret1& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)
          ret2& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName2, lphKey&)
          ret2& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)
          
      'This sets the command line for "glcs document".
          sKeyName1 = "glcs document"
          sKeyName2 = "glcs document"
          sKeyValue = App.Path & "\glcs.exe %1"
          
          ret1& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName1, lphKey&)
          ret1& = RegSetValue&(lphKey&, "shell\open\command", REG_SZ, sKeyValue, MAX_PATH)
          ret2& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName2, lphKey&)
          ret2& = RegSetValue&(lphKey&, "shell\open\command", REG_SZ, sKeyValue, MAX_PATH)
    
    
    Text1.Text = ""
    
    yemsz1 = 1
    yemsz2 = 1
    yemss = 1417.5
    yemsx = 1417.5
    yemsz = 1134
    yemsy = 1134
    bgztsz = "宋体"
    bgzhsz = 10
    btmch = "公 路 测 设 计 算 书"
    bgsxyj = 1
    
    bcwjpd = 0  '保存文件判断
    wjlj = ""
    
    '如果是双击文件，则打开该文件
    Dim ss As String    '定义一个字符变量
    ss = Command()      '最关键的一步！用这个函数来获得命令行参数！！就是上面提到的 "%1" ,换句话来说，就是文件名！
    If ss <> "" Then
        wjlj = ss
        
        wjstr = ""
        Open wjlj For Input As #1
            Do Until EOF(1)
                Line Input #1, wenb
                wjstr = wjstr & vbCrLf & wenb
            Loop
        Close #1
        Text1.Text = wjstr
        
        frmMain.Caption = "饮羽公路测设" + "    " + wjlj
        
        bcwjpd = 0
    End If
    
    rjsfzc = 88
    
    
    Exit Sub
handlerror:
    xianshi = MsgBox("在启动软件时出错，请重新安装", vbInformation, "问题提示")
    
End Sub

Private Sub Form_Resize()
'窗体调整
    
    On Error Resume Next
    
    If frmMain.Height - StatusBar1.Height - CoolBar1.Height - 740 > 0 Then
        Text1.Height = frmMain.Height - StatusBar1.Height - CoolBar1.Height - 740
    End If
    If frmMain.Width - 140 > 0 Then
        Text1.Width = frmMain.Width - 140
        CoolBar1.Width = Text1.Width
    End If

End Sub

Private Sub Form_Unload(Cancel As Integer)
'关闭按钮
    
    On Error GoTo handlerror
    
    If Trim$(Text1.Text) <> "" Then
        xianshi = MsgBox("请问，是否要保存数据文件？", vbYesNoCancel + vbExclamation, "问题提示")
        If xianshi = 6 Then      '是
            Call mnuFileSaveAs_Click
            Text1.Text = ""
        End If
        If xianshi = 2 Then     '取消
            Exit Sub
        End If
    End If
    
    Unload frmAbout
    Unload frmbazyq
    Unload frmbklcwc
    Unload frmbzwjct
    Unload frmcygs
    Unload frmdbxmj
    Unload frmdcnh
    Unload frmdyyl
    Unload frmfdcfs
    Unload frmfuqx
    Unload frmghqj
    Unload frmgljszz
    Unload frmhdchd
    Unload frmhjinj
    Unload frmhntphb
    Unload frmhwxjzb
    Unload frmjiakcg
    Unload frmjsq
    Unload frmlxqxjj
    Unload frmlxqxsj
    Unload frmMain
    Unload frmplfbzft
    Unload frmpqxfs
    Unload frmqdpd
    Unload frmqjxpqx
    Unload frmqxckz
    Unload frmqxfsu
    Unload frmsdyqxsj
    Unload frmsgwlt
    Unload frmshntpb
    Unload frmshzcl
    Unload frmsntshj
    Unload frmsqxjs
    Unload frmsxqxsj
    Unload frmtxpqx
    Unload frmtyzhb
    Unload frmwjkzh
    Unload frmxjdpqx
    Unload frmxxfc
    Unload frmyemsz
    Unload frmysdhd
    Unload frmyyqxnh
    Unload frmzdljjs
    Unload frmzhbzh
    Unload frmzhxhp
    Unload frmzjkz
    Unload frmzzddzb
    
    Exit Sub
handlerror:

End Sub

Private Sub fuquxian_Click()
'复曲线
    
    frmfuqx.Show vbModal, Me
    
End Sub

Private Sub gljsbz_Click()
'公路技术标准

    
    frmgljszz.Show vbModal, Me
    
End Sub

Private Sub hjinj_Click()
'计算横净距
    
    frmhjinj.Show vbModal, Me

End Sub

Private Sub hntphb_Click()
'混凝土配合比

    frmhntphb.Show vbModal, Me

End Sub

Private Sub hwxjzb_Click()
'红外线极坐标

    frmhwxjzb.Show vbModal, Me

End Sub

Private Sub jbxfsh_Click()
'基本型平曲线敷设

    frmpqxfs.Show vbModal, Me
    
End Sub

Private Sub jkchg_Click()
'加宽超高

    frmjiakcg.Show vbModal, Me
    
End Sub

Private Sub lxqxjqj_Click()
'卵型曲线精解

    frmlxqxjj.Show vbModal, Me
    
End Sub

Private Sub lxqxsj_Click()
'卵型曲线设计

    frmlxqxsj.Show vbModal, Me
    
End Sub

Private Sub menubzyq_Click()
'八字翼墙

    On Error GoTo handlerror
    
    frmbazyq.Show vbModal, Me
    
    Exit Sub
handlerror:

End Sub

Private Sub menucygsh_Click()
'常用公式

    On Error GoTo handlerror
    
    frmcygs.Show vbModal, Me
    
    Exit Sub
handlerror:
    
End Sub

Private Sub menuhdchd_Click()
'涵洞长度计算

    On Error GoTo handlerror
    
    frmhdchd.Show vbModal, Me
    
    Exit Sub
handlerror:

End Sub

Private Sub menujsq_Click()
'计算器
    
    On Error GoTo handlerror
    
    frmjsq.Show
    
    Exit Sub
handlerror:

End Sub

Private Sub menulxxjd_Click()
'两线相交

    On Error GoTo handlerror
    
    frmjfcjd.Show vbModal, Me
    
    Exit Sub
handlerror:

End Sub

Private Sub menuqdwb_Click()
'清空文本

    On Error GoTo handlerror
    
    xiansh = MsgBox("将清空文本文件，确定吗？", vbInformation + vbYesNo, "问题提示")
    If xiansh = 7 Then Exit Sub
    If xiansh = 6 Then
        Text1.Text = ""
    End If