frmodbclogon.frm

金算盘软件代码

'            Next
'            GoTo DispWindow
        'new---------------------------------------------
            blnDriverFind = False
            For DriverCount = 1 To UBound(DriverList)
                If DriverList(DriverCount) = DEFAULT_ODBC_DRIVER Then
                    txtDriver.AddItem DriverList(DriverCount)
                    blnDriverFind = True
                ElseIf DriverList(DriverCount) = "Microsoft ODBC for Oracle" Then
                    txtDriver.AddItem DriverList(DriverCount)
                    If txtDriver.Text = "" Then
                        txtDriver.Text = txtDriver.list(0)
                    End If
                    blnDriverFind = True
                End If
            Next
            If blnDriverFind = False Then
                ShowMsg frmMain.hwnd, "请安装“Microsoft ODBC for Oracle” 或“" & DEFAULT_ODBC_DRIVER & "”ODBC 驱动程序！", MB_ICONEXCLAMATION, "系统登录"
                End
                Exit Function
            End If
        'new end ----------------------------------------
    
DispWindow:
    If txtDriver.Text = "" Then
        If txtDriver.ListCount > 0 Then
            txtDriver.Text = txtDriver.list(0)
        End If
    End If
    Me.Show vbModal
    If b_blnSuss Then
       If sConnect <> "" Then
            strConnectString = sConnect
       Else
            strConnectString = "internal"
       End If
       If sDriver = "" Then
            strDriver = "用于 Oracle 的微软 ODBC 驱动器"
       Else
            strDriver = sDriver
       End If
       strPassWord = sPassword
    End If
    OpenBase = b_blnSuss
End Function

Private Sub CmdCancel_Click()
    b_blnSuss = False
    Unload Me
End Sub

Private Sub cmdConnect_Click()
   b_blnSuss = True
    SaveSetting AppTitle, "Login", "ConnectString", Trim(cboConnect.Text)
    SaveSetting AppTitle, "Login", "OdbcDriver", Trim(txtDriver.Text)
    SaveSetting AppTitle, "Login", "PassWord", Security(txtPass.Text)
   Unload Me
End Sub


Private Sub Form_Load()
    Me.Icon = Utility.LoadRes(139, vbResIcon)
    AddItem
'  Set mclsMainControl = gclsSys.MainControls.Add(Me)
End Sub

Private Sub Form_Unload(Cancel As Integer)
  sConnect = Trim(cboConnect.Text)
  sDriver = Trim(txtDriver.Text)
  sPassword = Trim(txtPass.Text)
  ' gclsSys.MainControls.Remove Me
End Sub

Public Function GetOdbcDriver() As Variant
   Dim ReturnValue As Long
   Dim lpSubKey As String
   Dim ulOptions As Long
   Dim samDesired As Long
   Dim phkResult As Long
   Dim HKEY As Long
   Dim dwIndex As String
   Dim lpName As String
   Dim cbName As Long
   Dim DriverList() As String
   Dim Counter As Integer
   Dim fileTime1 As FILETIME
   
   HKEY = HKEY_LOCAL_MACHINE
   lpSubKey = "Software\ODBC\ODBCINST.INI"
   ulOptions = 0
   samDesired = KEY_QUERY_VALUE
   ReturnValue = RegOpenKeyEx(HKEY, lpSubKey, ulOptions, samDesired, phkResult)
   
   ReDim DriverList(0)
   HKEY = phkResult
   If ReturnValue = ERROR_SUCCESS Then
      dwIndex = 0
      Counter = 0
      Do
         lpName = Space(200)
         cbName = 200
         ReturnValue = RegEnumKeyEx(HKEY, dwIndex, lpName, cbName, 0, "", 0, fileTime1)
         If InStr(1, UCase(lpName), "ORACLE") > 0 And _
            (InStr(1, UCase(lpName), UCase("Microsoft")) > 0 Or InStr(1, UCase(lpName), "微软") > 0) Then
            Counter = Counter + 1
            ReDim Preserve DriverList(Counter)
            DriverList(Counter) = Mid(lpName, 1, InStr(1, lpName, Chr(0)) - 1)
         End If
         dwIndex = dwIndex + 1
      Loop Until ReturnValue <> 0
   End If
   
   GetOdbcDriver = DriverList
   
End Function
Private Function GetKeyValue(KeyRoot As Long, KeyName As String, SubKeyRef As String) As String
    Dim i As Long                                           ' 循环计数器
    Dim rc As Long                                          ' 返回代码
    Dim HKEY As Long                                        ' 处理打开的注册表关键字
    Dim hDepth As Long                                      '
    Dim sKeyVal As String
    Dim lKeyValType As Long                                 ' 注册表关键字数据类型
    Dim tmpVal As String                                    ' 注册表关键字的临时存储器
    Dim KeyValSize As Long                                  ' 注册表关键字变量尺寸
    
    ' 在 KeyRoot {HKEY_LOCAL_MACHINE...} 下打开注册表关键字
    '------------------------------------------------------------
    rc = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, HKEY) ' 打开注册表关键字
    
    If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' 处理错误...
    
    tmpVal = String$(1024, 0)                             ' 分配变量空间
    KeyValSize = 1024                                       ' 标记变量尺寸
    
    '------------------------------------------------------------
    ' 检索注册表关键字的值...
    '------------------------------------------------------------
    rc = RegQueryValueEx(HKEY, SubKeyRef, 0, _
                         lKeyValType, tmpVal, KeyValSize)    ' 获得/创建关键字的值
                        
    If (rc <> ERROR_SUCCESS) Then GoTo GetKeyError          ' 错误处理
      
    tmpVal = Left$(tmpVal, InStr(tmpVal, Chr(0)) - 1)

    '------------------------------------------------------------
    ' 决定关键字值的转换类型...
    '------------------------------------------------------------
    Select Case lKeyValType                                  ' 搜索数据类型...
    Case REG_SZ, REG_EXPAND_SZ                              ' 字符串注册表关键字数据类型
        sKeyVal = tmpVal                                     ' 复制字符串的值
    Case REG_DWORD                                          ' 四字节注册表关键字数据类型
        For i = Len(tmpVal) To 1 Step -1                    ' 转换每一位
            sKeyVal = sKeyVal + Hex(Asc(Mid(tmpVal, i, 1)))   ' 一个字符一个字符地生成值。
        Next
        sKeyVal = Format$("&h" + sKeyVal)                     ' 转换四字节为字符串
    End Select
    
    GetKeyValue = sKeyVal                                   ' 返回值
    rc = RegCloseKey(HKEY)                                  ' 关闭注册表关键字
    Exit Function                                           ' 退出
    
GetKeyError:    ' 错误发生过后进行清除...
    GetKeyValue = vbNullString                              ' 设置返回值为空字符串
    rc = RegCloseKey(HKEY)                                  ' 关闭注册表关键字
End Function

Private Sub AddItem()
    cboConnect.Clear
    Dim strTmp As String
    Dim strPath As String
    Dim StrFileName As String
    Dim strContent As String
    strTmp = GetKeyValue(HKEY_LOCAL_MACHINE, "Software\ORACLE\ALL_HOMES", "LAST_HOME")
    If strTmp = "" Then
        Exit Sub
    End If
    strPath = GetKeyValue(HKEY_LOCAL_MACHINE, "Software\ORACLE\HOME" & strTmp, "ORACLE_HOME")
    If strPath = "" Then
        Exit Sub
    End If
    StrFileName = strPath & "\NET80\ADMIN\TNSNAMES.ORA"
            
'    Open StrFileName For Binary As #1
'    strContent = Input(LOF(1), #1)
'    Close #1
'    Do While Len(strContent) > 0
'        If InStr(1, strContent, vbCrLf) > 0 Then
'            strTmp = Left(strContent, InStr(1, strContent, Chr(13)))
'            strContent = Mid(strContent, InStr(1, strContent, Chr(13)) + 2)
'        Else
'            strTmp = strContent
'            strContent = ""
'        End If
'        If InStr(1, strTmp, ".") > 0 And InStr(1, strTmp, " =") And InStr(1, strTmp, "(") = 0 And InStr(1, strTmp, ")") = 0 Then
'            strTmp = Left(strTmp, InStr(1, strTmp, " ="))
'            strTmp = Trim(strTmp)
'            If InStr(1, strTmp, ".WORLD") > 1 Then
'                strTmp = Left(strTmp, InStr(1, strTmp, ".WORLD") - 1)
'            End If
'            If InStr(1, strTmp, "EXTPROC_CONNECTION_DATA") >= 1 Then
'            ElseIf InStr(1, strTmp, "BEQ-LOCAL") >= 1 Then
'            ElseIf InStr(1, strTmp, "NMPEXAMPLE") >= 1 Then
'            ElseIf InStr(1, strTmp, "TCPEXAMPLE") >= 1 Then
'            ElseIf InStr(1, strTmp, "SPXEXAMPLE") >= 1 Then
'            ElseIf InStr(1, strTmp, "TCP-LOOPBACK") >= 1 Then
'            ElseIf InStr(1, strTmp, "CMEXAMPLE") >= 1 Then
'            Else
'              cboConnect.AddItem strTmp
'            End If
'        End If
'    Loop
'    If cboConnect.ListCount > 0 Then
'        cboConnect.Text = cboConnect.list(0)
'    End If
End Sub