mymodule.bas

GIS+VB开发. GIS+VB开发.

Attribute VB_Name = "MyModule"

Public Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
'
Public Const RAS95_MaxEntryName = 256
Public Const RAS95_MaxDeviceType = 16
Public Const RAS95_MaxDeviceName = 32
'下面三个为调用动态连接库函数
Private Declare Function ReadPhysicalDrive Lib "Reg.dll" () As String
Private Declare Function GetCPUID Lib "Reg.dll" () As String
Public Declare Function GetMD5Str Lib "Reg.dll" (ByVal stra As String) As String
'获取注册
Public RegName As String, RegMail As String, RegCode As String, RegSerial As String, RegFlag As Boolean
Public Type RASCONN95
    dwSize As Long
    hRasCon As Long
    szEntryName(RAS95_MaxEntryName) As Byte
    szDeviceType(RAS95_MaxDeviceType) As Byte
    szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
'
Public Type RASCONNSTATUS95
    dwSize As Long
    RasConnState As Long
    dwError As Long
    szDeviceType(RAS95_MaxDeviceType) As Byte
    szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
        
Sub main()
Dim fs
Dim StrPath As String
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(App.Path + "\MapSearch.ini") Then
StrPath = App.Path + "\MapSearch.ini"
RegName = GetProfile(StrPath, "Register", "RegName")
RegMail = GetProfile(StrPath, "Register", "RegMail")
RegCode = GetProfile(StrPath, "Register", "RegCode")
RegSerial = GetMD5Str(ReadPhysicalDrive + GetCPUID)
If RegCode = GetMD5Str(RegName + RegMail + RegSerial) Then
  RegFlag = True
Else
  RegFlag = False
End If
FrmSplash.Show
Else
MsgBox "设置文件未找到，请重新安装"
End
End If
End Sub

Public Function IsConnected() As Boolean
Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim RetVal As Long
Dim Tstatus As RASCONNSTATUS95
'
TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize
'
RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)
If RetVal <> 0 Then
                    MsgBox "ERROR"
                    Exit Function
                    End If
'
Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)
If Tstatus.RasConnState = &H2000 Then
                         IsConnected = True
                         Else
                         IsConnected = False
                         End If

End Function
  

  Function setProfile(strFileName As String, strSection As String, strName As String, strSave As String) As Boolean
  '这个函数是用来对INI文件进行写操作的
  '函数说明:
  'strFileName 是所要存储的文件名
  'strSection  是这个文件中的一个节点名
  'strName 是所要查找的字段名
  'strSave 是所要替换字段值
  '薛向华 1998/05/13
  
  Dim strTemp As String
  Dim strfileback As String
  Dim strreturn As String
  strfileback = App.Path & "\xj.tmp" '临时文件是用来存放中转信息的
  
  Open strFileName For Input As #1
  Open strfileback For Output As #2
   Do While Not EOF(1)
    Line Input #1, strTemp
    strreturn = strTemp
    Print #2, strreturn
    If InStr(1, Trim(strTemp), "[") <> 0 Then
      If InStr(1, Trim(strTemp), Trim(strSection)) <> 0 Then
        Do While Not EOF(1)
            Line Input #1, strTemp
            If InStr(1, Trim(strTemp), Trim(strName)) <> 0 Then Exit Do  '找到所要修改的字段值
            strreturn = strTemp
            Print #2, strreturn  '拷贝不需要的字段值
         Loop
         strreturn = strName & "=" & strSave  '修改
         Print #2, strreturn
      End If
    End If
   Loop
  Close #1
  Close #2
  Open strfileback For Input As #1
  Open strFileName For Output As #2
  Do While Not EOF(1) And EOF(2)
  Line Input #1, strreturn
   Print #2, strreturn
  Loop
  Close #1
  Close #2
End Function
Function GetProfile(strFileName As String, strSection As String, strName As String) As String
  '这个函数是用来对INI文件进行读操作的
  '函数说明:
  'strFileName 是所要读取的文件名
  'strSection  是这个文件中的一个节点名
  'strName 是所要查找的字段名
  '返回值：
  '薛向华 1998/05/13
   strSectionTemp = ""
   strNameTemp = ""
   strreturn = ""
   On Error GoTo ErrSrchSection
   Open strFileName For Input As #1
   ' 下面这段程序是用来查找节点的
     Do While Not EOF(1)
        strCharA = Input(1, #1)
        If strCharA = "[" Then
           Do While Not EOF(1)
             strCharB = Input(1, #1)
             If strCharB = "]" Then Exit Do
             strSectionTemp = strSectionTemp & strCharB
           Loop
        End If
        If strSectionTemp = strSection Then
          strCharA = Input(2, #1)
          Exit Do
        Else
          strSectionTemp = ""
        End If
     Loop
 On Error GoTo ErrReadFile
  
aa:
    '下面这段程序是用来查找所要查找的字段的
    strNameTemp = ""
    Do While Not EOF(1)
      strCharA = Input(1, #1)
      If strCharA <> "=" Then
        strNameTemp = strNameTemp & strCharA  '得到名称
      Else
        Exit Do
      End If
    Loop
        If strNameTemp = strName Then
       Line Input #1, strreturn  '如果找到与它匹配的字段名，就返回得到的值
    Else
       Line Input #1, strreturn  '如果未找到与它匹配的字段名，就继续找
       GoTo aa
    End If
    Close #1
    GetProfile = strreturn
    Exit Function
ErrReadFile:
    Dim inrRet As Integer
    intret = MsgBox("在文件中没有找到所要查找的字段", vbAbortRetryIgnore, "错误信息")
    Select Case intret
       Case vbAbort
          GetProfile = ""
          Close #1
          Exit Function
       Case vbRetry
          Resume
       Case vbIgnore
          Resume Next
     End Select
ErrSrchSection:
     MsgBox "节点未找到", vbOKOnly
     GetProfile = ""
     Close #1
End Function