www.pudn.com > DataCollectionSystem.rar > modStand.bas, change:2003-07-09,size:13302b


Attribute VB_Name = "modStand" 
Option Explicit 
 
Public MOrigin As Integer    '基准点个数 
Public NOrigin As Integer    '监测点个数 
 
Public M As Integer    '基准点个数 
Public N As Integer    '监测点个数 
 
 
Public PtSX(300) As Integer 
Public Const CONV_RAD_TO_GON = 63.66197724 ' convert factor rad to gon 
Public Const FULL_CIRCLE_GON = 400         ' full circle in unit gon 
Public Const CONV_RAD_TO_DFM = 57.2957795130823 'convert factor rad to dfm 
Public Const CONV_DFM_TO_RAD = 1.74532925199433E-02 'convert factor dfm to rad 
Public Const CONV_DFM_TO_RADF = 2.90888208665722E-04  'convert f to rad 
Public Const CONV_DFM_TO_RADM = 4.84813681109536E-06  ' convert m to rad 
Public Const pi = 3.14159265358979 
Public Const ROU = 206265 
 
'comunication 
Public ComPort     As Long ' RS232 port number 
Public Baudrate    As Long ' GeoCOM Baudrate 
Public Protocol    As Long ' GeoCOM Protocol (ASCII or Binary) 
 
'仪器测得的X坐标,Y坐标,Z坐标 
Public Xp(100) As Double, Yp(100) As Double, Zp(100) As Double 
'三个方向累计沉降量 
'Public Sumdx(100) As Double, Sumdy(100) As Double, Sumdz(100) As Double 
Public fGCdate As String, fGCtime(100) As String 
Public fdH(100) As Integer, fdM(100) As String 
Public fMcycle As Long, fPhz(100) As Double, fPV(100) As Double, fPdist(100) As Double 
Public fXp(100) As Double, fYp(100) As Double, fZp(100) As Double 
Public fsm(100) As Integer 
 
Public Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long 
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long 
 
'Delay for some times 
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 
Declare Function SleepEx Lib "kernel32" (ByVal dwMilliseconds As Long, ByVal bAlertable As Long) As Long 
 
Public Const WM_USER As Long = &H400 
Public Const SB_GETRECT As Long = (WM_USER + 10) 
Public Const NameNotInCollection = 3265 
Public Const EM_LINESCROLL = &HB6 
 
Global Const gFIXEDROWS = 1 
Public Const gGridBackColor = &H80000018 
Public Const gGridForeColor = &H0 
Public Const gCellSelBackColor = &H80000001 '查询结果的背景色 
Public Const gCellSelForeColor = vbWhite 
Public Const gTRUE = -1 
Public Const gFALSE = 0 
 
Public Declare Function SendMessageBynum& Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) 
 
'以下四行代码可以控制文本框文本的滚动(需将MultiLine设置为True) 
'SendMessageBynum Text1.hwnd, EM_LINESCROLL, 0, 1 ' 下卷一行 
'SendMessageBynum Text1.hwnd, EM_LINESCROLL, 0, -1 ' 上卷一行 
'SendMessageBynum Text1.hwnd, EM_LINESCROLL, 1, 0 ' 右卷一列 
'SendMessageBynum Text1.hwnd, EM_LINESCROLL, -1, 0 ' 左卷一列 
 
Public Const GCL_HCURSOR = -12 
 
Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long 
Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Any) As Long 
Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As String) As Long 
Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long 
Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long 
 
 
Public Const EM_SETREADONLY = (WM_USER + 31) 
Public Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long 
Public Const SWP_DRAWFRAME = &H20 
Public Const SWP_NOMOVE = &H2 
Public Const SWP_NOSIZE = &H1 
Public Const SWP_NOZORDER = &H4 
Public Const SWP_FLAGS = SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Or SWP_DRAWFRAME 
Public Const HWND_TOP = 0 
Public Const HWND_NOTOPMOST = -2 
Public Const HWND_BOTTOM = 1 
Public Const HWND_TOPMOST = -1 
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long 
Public Declare Function SendMessageAny Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, lParam As Any) As Long 
 
Public Declare Function GetCapture Lib "user32" () As Long 
Public Declare Function ReleaseCapture Lib "user32" () As Long 
Public Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long 
 
Public Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" _ 
   (ByVal hwnd As Long, _ 
    ByVal Msg As Long, _ 
    ByVal wParam As Long, _ 
    ByVal lParam As Long _ 
    ) As Long 
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _ 
    (ByVal hwnd As Long, _ 
    ByVal nIndex As Long _ 
    ) As Long 
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ 
   (ByVal hwnd As Long, _ 
    ByVal nIndex As Long, _ 
    ByVal dwNewLong As Long _ 
    ) As Long 
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" _ 
   (ByVal hObject As Long, _ 
   ByVal nCount As Long, _ 
   lpObject As Any _ 
   ) As Long 
Public Declare Function SelectObject Lib "gdi32" _ 
   (ByVal hDC As Long, _ 
   ByVal hObject As Long _ 
   ) As Long 
Public Declare Function DeleteObject Lib "gdi32" _ 
   (ByVal hObject As Long) As Long 
 
Public Const LVM_FIRST = &H1000 
Public Const LVM_SETEXTENDEDLISTVIEWSTYLE = LVM_FIRST + 54 
Public Const LVM_GETEXTENDEDLISTVIEWSTYLE = LVM_FIRST + 55 
Public Const LVS_EX_FULLROWSELECT = &H20 
Public Const LVS_EX_GRIDLINES = &H1 
Public Const LVS_EX_CHECKBOXES = &H4 
Public Const LVS_EX_HEADERDRAGDROP = &H10 
Public Const LVS_EX_TRACKSELECT = &H8 
Public Const LVS_EX_ONECLICKACTIVATE = &H40 
Public Const LVS_EX_TWOCLICKACTIVATE = &H80 
Public Const LVS_FULLROWSELECT = &H20 
 
Public Const HDS_BUTTONS = &H2 
Public Const LVM_GETHEADER = (LVM_FIRST + 31) 
 
Public Const HDS_HOTTRACK = &H4 
Public Const HDI_BITMAP = &H10 
Public Const HDI_IMAGE = &H20 
Public Const HDI_ORDER = &H80 
Public Const HDI_FORMAT = &H4 
Public Const HDI_TEXT = &H2 
Public Const HDI_WIDTH = &H1 
Public Const HDI_HEIGHT = HDI_WIDTH 
Public Const HDF_LEFT = 0 
Public Const HDF_RIGHT = 1 
Public Const HDF_IMAGE = &H800 
Public Const HDF_BITMAP_ON_RIGHT = &H1000 
Public Const HDF_BITMAP = &H2000 
Public Const HDF_STRING = &H4000 
Public Const HDM_FIRST = &H1200 
Public Const HDM_SETITEM = (HDM_FIRST + 4) 
 
Public Type HD_ITEM 
   mask        As Long 
   cxy         As Long 
   pszText     As String 
   hbm         As Long 
   cchTextMax  As Long 
   fmt         As Long 
   lParam      As Long 
   iImage      As Long 
   iOrder      As Long 
End Type 
' API Types 
 
'Sub Main() 
'    DoEvents 
'End Sub 
 
'************************************** 
'Encrypt/Decrypt 
'************************************** 
 
'Modified to shift characters in password by 5 characters 
Function Encrypt(strPW As String) 
     
    Dim intLetterCntr As Integer 
    Dim strLetter As String 
    Dim intLetter As Integer 
    Dim strEncPW As String 
     
    strEncPW = "" 
     
    For intLetterCntr = 1 To Len(strPW) 
        strLetter = Mid(strPW, intLetterCntr, 1) 
        intLetter = (Asc(strLetter) + 5) 
        ' if you want to change it from 5 chars to 
        ' whatever...do it in the decrypt too 
         
        If intLetter > 122 Then 
            intLetter = intLetter - 26 
        End If 
         
        strEncPW = strEncPW & Chr(intLetter) 
         
    Next intLetterCntr 
    Encrypt = strEncPW 
     
End Function 
 
 
Function decrypt(strEncPW As String) 
    Dim intLetterCntr As Integer 
    Dim strLetter As String 
    Dim intLetter As Integer 
    Dim strDecPW As String 
     
    strDecPW = "" 
     
    For intLetterCntr = 1 To Len(strEncPW) 
        strLetter = Mid(strEncPW, intLetterCntr, 1) 
        intLetter = (Asc(strLetter) - 5) 
        ' right here 
         
        If intLetter < 97 Then 
            intLetter = intLetter + 26 
        End If 
         
         
        strDecPW = strDecPW & Chr(intLetter) 
         
    Next intLetterCntr 
    decrypt = strDecPW 
     
End Function 
 
'延时过程,Int_Time 以秒为单位 
Public Sub Delay(ByVal Int_Time As Integer) 
   Dim start 
   start = Timer 
   Do While Timer - start < Int_Time: DoEvents: Loop 
End Sub 
 
Public Function GetMaxDayInAMonth(myYear As Integer, MyMonth As Integer) As Integer 
If MyMonth = 2 Then 
    If (myYear Mod 400) = 0 Then 
        GetMaxDayInAMonth = 29 
    ElseIf (myYear Mod 100) = 0 Then 
        GetMaxDayInAMonth = 28 
    ElseIf (myYear Mod 4) = 0 Then 
        GetMaxDayInAMonth = 29 
    Else 
        GetMaxDayInAMonth = 28 
    End If 
Else 
    If MyMonth < 8 Then 
        GetMaxDayInAMonth = IIf((MyMonth Mod 2) = 0, 30, 31) 
    Else 
        GetMaxDayInAMonth = IIf((MyMonth Mod 2) = 0, 31, 30) 
    End If 
End If 
End Function 
 
Public Sub GotFocus(Text1 As TextBox) 
    Text1.SelStart = 0 
    Text1.SelLength = Len(Text1.Text) 
End Sub 
 
Public Sub SendKeyTab(KeyCode As Integer) 
    If KeyCode = 13 Then 
        SendKeys "{TAB}" 
    End If 
End Sub 
 
Public Sub EditGridTxt(msfGrid As MSFlexGrid, obj As Control, Optional aPosition As AlignmentConstants = vbLeftJustify) 
    Dim i As Long 
    With msfGrid 
        If .Row = 0 Then 
            obj.Visible = False 
            Exit Sub 
        End If 
        If TypeOf obj Is TextBox Or TypeOf obj Is ComboBox Then 
            obj.Visible = False 
            obj.Width = .CellWidth 
            If TypeOf obj Is TextBox Then 
                obj.Text = "" 
                obj.Top = .Top + .CellTop 
                obj.Left = .Left + .CellLeft 
                obj.Height = .CellHeight 
                obj.Left = .Left + .CellLeft 
                obj.Alignment = aPosition 
                obj.Text = .Text 
                obj.SelStart = 0 
                obj.SelLength = Len(obj) 
            ElseIf TypeOf obj Is ComboBox Then 
                obj.Top = .Top + .CellTop 
                obj.Left = .Left + .CellLeft 
                For i = 0 To obj.ListCount 
                    If obj.List(i) = Trim(.Text) Then 
                        If Trim(.Text) = Empty Then 
                            If obj.ListCount > 0 Then 
                                obj.ListIndex = 0 
                            End If 
                        Else 
                            obj.ListIndex = i 
                        End If 
                        Exit For 
                    End If 
                Next 
            End If 
         
            obj.Visible = True 
            obj.SetFocus 
        End If 
    End With 
End Sub 
 
Public Sub KeyDownByUpDown(tmpGrid As MSFlexGrid, KeyCode As Integer) 
    Dim sRow, SCol As Integer 
    With tmpGrid 
        Select Case KeyCode 
            Case vbKeyDown 
                sRow = .Row + 1 
                If sRow = .Rows Then 
                    sRow = .FixedRows + 1 
                End If 
            Case vbKeyUp 
                sRow = .Row - 1 
                If sRow = 0 Then 
                    sRow = .Rows - 1 
                End If 
        End Select 
        SCol = .Col 
        .Row = sRow 
        .Col = SCol 
        .RowSel = sRow 
    End With 
End Sub 
 
Public Sub SetGridColor(myGrid As MSFlexGrid) 
    With myGrid 
        .RowHeight(.FixedRows - 1) = 300 
        .BackColor = gGridBackColor '&H80000018  '&HC0FFFF '&HC0FFC0 
        .BackColorFixed = &HC0C0C0  '&HC0FFC0 
        .ForeColorFixed = &HC00000  ' &H0&      '&HFF00FF  '&HC0&    &HFF0000   '  '&H80000002 '&HC00000   ' 
        .ForeColor = gGridForeColor ' &H0 
        .BackColorSel = &H8000000D '&HC00000 
        .GridColor = &HC0C0C0 
        .GridColorFixed = &H0&      ' &H808080  ' &HC0C0C0 
        .BackColorBkg = &H80000018 ' &HFFFFFF ''&HC0FFFF 
        .AllowUserResizing = flexResizeColumns 
        .ScrollBars = flexScrollBarBoth 
        .Rows = gFIXEDROWS 
    End With 
End Sub 
 
Public Function ValiText(KeyIn As Integer, ValidateString As String, Editable As Boolean) As Integer 
    Dim ValidateList As String 
    Dim KeyOut As Integer 
    If Editable = True Then 
         ValidateList = UCase(ValidateString) & Chr(8) 
    Else 
         ValidateList = UCase(ValidateString) 
    End If 
    If InStr(1, ValidateList, UCase(Chr(KeyIn)), 1) > 0 Then 
        KeyOut = KeyIn 
    Else 
        KeyOut = 0 
        Beep 
    End If 
    ValiText = KeyOut 
End Function 
 
'function Rad change to Dfm 
Public Function RadToDfm(ByVal varRad As Double) As Double 
    Dim s As Double, d As Double, f As Double, mm As Double 
      
    If varRad >= 2 * pi Then varRad = varRad - 2 * pi 
     
    s = varRad * CONV_RAD_TO_DFM 
     
    d = Fix(s) 
    f = Fix((s - d) * 60) 
    mm = ((s - d) * 60 - f) * 60 
      
    RadToDfm = Round((d + f / 100 + mm / 10000), 6) 
End Function 
 
'function Dfm change to Rad 
Public Function DfmToRad(ByVal varDfm As Double) As Double 
  
   Dim dp As Double, fp As Double, mp As Double 
   If varDfm = 0# Then 
      DfmToRad = 0# 
      Exit Function 
   End If 
    
   dp = Fix(varDfm) 
   fp = Fix((varDfm - Fix(varDfm)) * 100) 
   mp = Round((varDfm * 100 - Fix(varDfm * 100)) * 100, 2) 
    
   DfmToRad = dp * CONV_DFM_TO_RAD + fp * CONV_DFM_TO_RADF + mp * CONV_DFM_TO_RADM 
  
End Function