cmodule.bas

开发环境：VB6.0 数据库：SQLServer2000 说明：这是一个图库管理系统

    GetSys = True
    Exit Function
Err:
    Select Case Err.Number
    Case 90
        strIp = "数据库连接失败,错误位置：GetSys()"
    Case 91
        strIp = "没有得到系统路径,错误位置：GetSys()"
    Case Else
        strIp = "系统出错！错误描述：" & Err.Description & "错误位置：GetSys()"
    End Select
    Call CloseRs(objRs)
    'Call CloseCon
    GetSys = False
End Function
'*************************************************************
'函数名：GetConfig
'参数：  strValue:    标签名
'        strTmp :     项目名
'        strConfig:   项目内容
'功能：取出配置文件中项目的内容
'返回：成功：true 失败：false
'**************************************************************
Public Function GetConfig(ByVal strValue As String, ByVal strTmp As String, ByRef strConfig As String) As Boolean
    On Error GoTo Err
    strConfig = String$(200, Chr(32))
    Call GetPrivateProfileString(strValue, strTmp, "", strConfig, Len(strConfig), App.Path + "\config.ini")
    strConfig = Trim(strConfig)
    strConfig = Left(strConfig, Len(strConfig) - 1)
    GetConfig = True
    Exit Function
Err:
    strConfig = "读配置[" & strValue & "-" & strTmp & "]错误！错误描述：" & Err.Description
    GetConfig = False
End Function

'*************************************************************
'函数名：WriteConfig
'参数：  strValue:    标签名
'        strTmp :     项目名
'        strConfig:   项目内容
'功能：写入配置文件中项目的内容
'返回：成功：true 失败：false
'**************************************************************

Public Function WriteConfig(ByVal strValue As String, ByVal strTmp As String, ByRef strConfig As String) As Boolean
    On Error GoTo Err
    If WritePrivateProfileString(strValue, strTmp, strConfig, App.Path + "\config.ini") = False Then
        Err.Raise 90
    End If
    WriteConfig = True
    Exit Function
Err:
    strConfig = "写配置[" & strValue & "-" & strTmp & "]错误！错误描述：" & Err.Description
    WriteConfig = False
End Function


'*************************************************************
'过程名：    XCopyFile
'参数：      from_file:文件或者路径（返回） to_file:目的路径或者文件名
'过程功能：  将源文件或者源路径拷贝至目的路径
'返回：      成功：true 失败：false
'*************************************************************

'Private Function XCopyFile(ByRef from_file As String, ByVal to_file As String) As Boolean
'
'    On Error GoTo Err
'    ' 确定是否为路径
'    If GetAttr(from_file) And vbDirectory Then
'        If Right$(from_file, 1) <> "\" Then from_file = from_file & "\"
'        If Right$(to_file, 1) <> "\" Then to_file = to_file & "\"
'
'        ' 创建目录
'        MkDir to_file
'        ' 拷贝源文件目录下所有文件到目的目录
'        XCopyFile = CopyFiles(from_file, to_file)
'    Else
'        ' 为文件，拷贝文件
'        FileCopy from_file, to_file
'
'    End If
'
'    XCopyFile = True
'    Exit Function
'Err:
'    XCopyFile = False
'    from_file = Err.Description
'End Function
'****************************************************
'函数名：OpenFile()
'参数：  mfile:文件名 strErr:错误信息
'函数功能： 打开文件
'返回： 成功：true 失败：false
'****************************************************
Public Function OpenFile(ByVal mfile As String, ByRef strErr As String) As Boolean
    Dim lngRet As Long
    Dim mIp As String
    Dim Mpath As String
    On Error GoTo Err
    
    '打开文件
    lngRet = ShellExecute(GetDesktopWindow(), "OPEN", mfile, vbNullString, App.Path, SW_SHOWNORMAL)
    If lngRet < 32 Then
        Select Case lngRet
            Case ERROR_FILE_NOT_FOUND
                Err.Raise 91
            Case ERROR_PATH_NOT_FOUND
                Err.Raise 92
            Case ERROR_BAD_FORMAT
                Err.Raise 93
            Case SE_ERR_NOASSOC
                Err.Raise 94
            Case Else
                Err.Raise 95
        End Select
    End If
    OpenFile = True
    Exit Function
Err:
    Select Case Err.Number
    Case 91
        strErr = "文件不存在,错误位置：OpenFile()"
    Case 92
        strErr = "路径不存在,错误位置：OpenFile()"
    Case 93
        strErr = "error Format,错误位置：OpenFile()"
    Case 94
        strErr = "对不起，没有打开此类文件的可执行文件,错误位置：OpenFile()"
    Case Else
        strErr = "系统错误，错误信息：" & Err.Description & "错误位置：OpenFile()"
    End Select
    OpenFile = False
End Function
'**********************************************************
'函数名：GetNodePath()
'参数：  Mnode:当前节点 Mpath:当前节点路径
'函数功能：取得当前节点的路径
'返回： 成功：true 失败：false
'**********************************************************
Public Function GetNodePath(ByVal mnode As Node, ByRef Mpath As String) As Boolean
    On Error GoTo Err
    Do While True
       If mnode.Text = "字典平台" Then
             Mpath = "\\" & CModule.objIp & "\" & CModule.objPath & "data\" & Mpath
            Exit Do
       End If
       Mpath = Trim(mnode.Text) & "\" & Mpath
       Set mnode = mnode.Parent
    Loop
    GetNodePath = True
    Exit Function
Err:
    Mpath = Err.Description
    GetNodePath = False
    
End Function
Public Function DeleteNode(ByRef strText As String) As Boolean
    Dim strSql As String
    Dim strType As String
    Dim IntIndex As Integer
    Dim obj As New ADODB.Recordset
    '数据库连接
    On Error GoTo Err
    If CModule.IsConnect() = False Then
        Err.Raise 90
    End If
    '提取该记录的父目录和该项的序号
    strSql = "select * from zdk where zdCode='" & strText & "'"
    obj.Open strSql, CModule.objCon, adOpenStatic, adLockOptimistic, adCmdText
    If obj.EOF Then
        Err.Raise 91
    End If
    strType = Trim(obj("zdType"))
    IntIndex = obj("zdIndex")
    obj.Close
    '删除该项
    strSql = "DELETE FROM zdk where zdCode='" & strText & "'"
    CModule.objCon.Execute strSql
    '更新比此项序号大兄弟项的序号
    strSql = "update zdk set zdindex=zdindex-1 where zdType='" & strType & "' and zdindex>" & IntIndex
    CModule.objCon.Execute strSql
    DeleteNode = True
    Exit Function
Err:
    Select Case Err.Number
    Case 90
        strText = "数据库连接失败！错误位置：DeleteNode()"
    Case 91
        strText = "删除数据出错！错误位置：DeleteNode()"
    Case Else
        strText = "系统错误，错误描述：" & Err.Description & "错误位置：DeleteNode()"
    End Select
    DeleteNode = False
End Function
Public Function GetExe(ByVal strDes As String, ByRef strExtend As String, ByRef strFormat As String) As Boolean
    Dim objRs As New ADODB.Recordset
    Dim strSql As String
    On Error GoTo Err
    '数据库连接
    If CModule.IsConnect() = False Then
        Err.Raise 90
    End If
    strSql = "select * from SysExe where ExeDes='" & Trim(strDes) & "'"
    objRs.Open strSql, CModule.objCon, adOpenStatic, adLockOptimistic, adCmdText
    If objRs.EOF Then
        Err.Raise 91
    End If
    strExtend = objRs("ExeExtend")
    strFormat = objRs("FormatName")
    CModule.CloseRs objRs
    GetExe = True
    Exit Function
Err:
    Select Case Err.Number
    Case 90
        strExtend = "数据库连接失败,错误位置:GetExe()"
    Case 91
        strExtend = "没有找到相应的信息,错误位置:GetExe()"
    Case Else
        strExtend = "系统错误,错误描述:" & Err.Description & "错误位置:GetExe()"
    End Select
    CModule.CloseRs objRs
    GetExe = False
End Function