mdlfunction.bas

一个把自己的东西刻成光盘后自动查询和启动的原代码

Attribute VB_Name = "MdlFunction"

'####################################################################
'数据库连接函数，返回值Boolean
'####################################################################
Public Function CntDB() As Boolean
On Error GoTo Err
Dim s As String
Dim fs As FileSystemObject
Set fs = CreateObject("Scripting.FileSystemObject")

gErrDescription = ""
If Dir(App.Path + "\Temp", vbDirectory) = "" Then MkDir App.Path + "\Temp"
fs.CopyFile gCDPath + "\data\DiskDB.mdb", App.Path + "\temp\diskdb.mdb", True
fs.GetFile(App.Path + "\temp\diskdb.mdb").Attributes = Normal

'ODBC连接
Set gWrks = DBEngine.CreateWorkspace("aa", "admin", "")
'Set gDbs = gWrks.OpenDatabase(gCDPath + "\data\DiskDB.mdb")
Set gDbs = gWrks.OpenDatabase(App.Path + "\temp\diskdb.mdb")

CntDB = True
Exit Function
Err:
   gErrDescription = "连接数据库失败"
   CntDB = False
   MsgErr "连接数据库", "1006", gErrDescription, True, LXGLY, Err.Description
End Function

'####################################################################
'系统初始化创建注册表函数，返回值Boolean
'####################################################################
Public Function CreateReg() As Boolean
On Error GoTo Err

If RegSetString(HKEY_LOCAL_MACHINE, gRegSubKey + "\DSN", "DSN", "AMS") = False Then GoTo Err
If RegSetString(HKEY_LOCAL_MACHINE, gRegSubKey + "\DSN", "UserID", "icbcdoc") = False Then GoTo Err
If RegSetString(HKEY_LOCAL_MACHINE, gRegSubKey + "\DSN", "PWD", "order") = False Then GoTo Err

CreateReg = True
Exit Function
Err:
   CreateReg = False
End Function

'####################################################################
'系统统一时间，返回值Boolean
'####################################################################
Public Sub KeepTime()
On Error GoTo Err
Shell "net time \\PDC /set /y"
Exit Sub
Err:
End Sub

'####################################################################
'系统初始化读注册表函数，返回值Boolean
'####################################################################
Public Function LoadReg() As Boolean
On Error GoTo Err

If RegGetString(HKEY_LOCAL_MACHINE, gRegSubKey + "\DSN", "DSN", gDSN) = False Then GoTo Err
If RegGetString(HKEY_LOCAL_MACHINE, gRegSubKey + "\DSN", "UserID", gUserID) = False Then GoTo Err
If RegGetString(HKEY_LOCAL_MACHINE, gRegSubKey + "\DSN", "PWD", gPwd) = False Then GoTo Err

LoadReg = True
Exit Function
Err:
   LoadReg = False
End Function

'####################################################################
'系统主函数
'####################################################################
Public Sub Main()
On Error GoTo Err
Dim i As Integer
Dim j As Integer
Dim t As String

FrmSplash.Show
DoEvents

gErrDescription = ""
gConvert_To_Dict = True
gDiskCapacity = 620000000

If App.PrevInstance Then
   MsgBox "单机查询客户端正在运行。不能多次启动！", vbOKOnly Or vbInformation, XTTS
   End
End If

If LoadReg = False Then
   If CreateReg = False Then GoTo Err
End If
If LoadReg = False Then GoTo Err

gIsPath = GetCDDrive(gCDPath)

If gIsPath = False Then
   FrmSelCDPath.Show 1
   If gIsPath = False Then End
End If
Call CntDB
'Call AddTable(True, "WENSHU", "")

FrmLogin.Show 1
If gLoginSuccess = False Then End

'Call KeepTime
gComputerName = GetComPuter
FrmMain.Show
DoEvents
Call FrmMain.FrmInit
Call GetIEPath(g_IE_Path)
Call RemoveFile(App.Path + "\temp\*.*")
Call RemoveFile(App.Path + "\*.s2")
If FrmSplash.Visible = True Then Unload FrmSplash
Exit Sub
Err:
   MsgErr "系统初始化", "1001", gErrDescription, True, LXGLY, Err.Description
   End
End Sub

'####################################################################
'系统报错函数，返回值Boolean
'####################################################################
Public Sub MsgErr(ErrSource As String, ErrCode As String, ErrDes As String, ViewMsgBox As Boolean, PromptStr As String, SysErr As String)
On Error GoTo Err
If ViewMsgBox = True Then
   If PromptStr = "" Then
      MsgBox "错误来源：" + ErrSource + Chr(10) + "错误代码：" + ErrCode + Chr(10) + "错误描述：" + ErrDes + Chr(10) + "系统描述：" + Err.Description, vbExclamation, "系统错误"
   Else
      MsgBox "错误来源：" + ErrSource + Chr(10) + "错误代码：" + ErrCode + Chr(10) + "错误描述：" + ErrDes + Chr(10) + "系统描述：" + Err.Description + Chr(13) + Chr(13) + PromptStr, vbExclamation, "系统错误"
   End If
End If
'写日志
Close #1
Open App.Path + "\ErrorLog.txt" For Append As #1
   Print #1, "错误时间：" + Format(Date, "yyyy-mm-dd") + " " + Format(Time, "hh:mm:ss")
   Print #1, "错误来源：" + ErrSource + " 错误描述：" + ErrDes
   Print #1, "错误代码：" + ErrCode + " 系统描述：" + SysErr
   Print #1, ""
Close #1
Err: '写日志
End Sub


'#########################################################################
'设置节点对象信息
'参数：p_NodeInfo要设置的节点对象 p_NodeKey 节点关键字
'返回Boolean 调用FrmMain
'#########################################################################
Public Function SetNodeInfo(p_NodeInfo As NodeInfo, p_NodeKey As String) As Boolean
On Error GoTo Err
With p_NodeInfo
  .Where_Str = ""
  '.Order_Str = ""
  .Node_ID = ""
  .Table_Name = ""
  .Field_Value = ""
  .Field_En_Name = ""
  '.Where_Str = ""
  Call GetValue(.Where_Str, "WHERE", p_NodeKey)
  'Call GetValue(.Order_Str, "ORDER", p_NodeKey)
  Call GetValue(.Node_ID, "NODE_ID", p_NodeKey)
  Call GetValue(.Field_En_Name, "FIELD_EN_NAME", p_NodeKey)
  Call GetValue(.Table_Name, "TABLE_NAME", p_NodeKey)
  Call GetValue(.Field_Value, "VALUE", p_NodeKey)
End With
SetNodeInfo = True
Exit Function
Err:
   SetNodeInfo = False
End Function


'###################################################################################
'关闭数据库全局变量对象
'###################################################################################
Public Sub CloseDB()
On Error GoTo Err
If Not (gRst Is Nothing) Then gRst.Close
If Not (gDbs Is Nothing) Then gDbs.Close
If Not (gWrks Is Nothing) Then gWrks.Close

Err:
End Sub

'###################################################################################
'清除临时文件 p_Path要清除文件的路径
'###################################################################################
Public Sub RemoveFile(p_Path As String)
On Error GoTo Err
'清除临时文件

Kill p_Path
Err:
End Sub

'###################################################################################
'根据控件获取字段名称及字段值
'参数：p_Main_Control 显示字段信息的控件 p_Is_In_Where 返回的字段值是否在Sql语句中
'返回：Boolean是否转换成功 p_Field_Name 返回字段的名称 p_Field_Value 返回的字段值
'###################################################################################
Public Function CtlToString(p_Main_Control As Control, p_Field_Name As String, _
    p_Field_Value As String, p_Is_In_Where As Boolean, p_Is_Defined As Boolean) As Boolean
On Error GoTo Err
'p_Main_Control.tag 中 @F Field_Name @ P Data_Type @D System_Dict_Type
Dim tFieldName As String
Dim t_Data_Type As String
Dim t_Dict_Type As String
Dim t_Permit_Null As Boolean

Dim tStr As String

p_Field_Name = ""
p_Field_Value = ""
p_Is_Defined = False

If GetValue(p_Field_Name, "Field_Name", p_Main_Control.Tag) = False Then GoTo Err
If GetValue(t_Data_Type, "Data_Type", p_Main_Control.Tag) = False Then GoTo Err
If GetValue(t_Dict_Type, "Dict_Type", p_Main_Control.Tag) = False Then GoTo Err
If GetValue(tStr, "Is_Null", p_Main_Control.Tag) = False Then GoTo Err
If tStr = 1 Then
   t_Permit_Null = True
Else
   t_Permit_Null = False
End If
If GetValue(tStr, "Is_Defined", p_Main_Control.Tag) = False Then GoTo Err
If tStr = 1 Then
   p_Is_Defined = True
Else
   p_Is_Defined = False
End If

If TypeOf p_Main_Control Is TextBox Or TypeOf p_Main_Control Is RichTextBox Then
   p_Field_Value = Convert_Value(p_Main_Control.Text, 1, CInt(t_Data_Type), p_Is_In_Where, t_Permit_Null)
ElseIf TypeOf p_Main_Control Is ComboBox Then
   If p_Main_Control.ListIndex = -1 Then
      p_Field_Value = "-1"
   Else
      p_Field_Value = Convert_Value(p_Main_Control.ItemData(p_Main_Control.ListIndex), 1, CInt(t_Data_Type), p_Is_In_Where, t_Permit_Null)
   End If
ElseIf TypeOf p_Main_Control Is MaskEdBox Then
   p_Field_Value = Convert_Value(p_Main_Control.Text, 1, CInt(t_Data_Type), p_Is_In_Where, t_Permit_Null)
Else
   GoTo Err
End If
CtlToString = True
Exit Function
Err:
   CtlToString = False
   MsgErr "获取控件值", "2050", "", False, "", Err.Description
End Function

'###################################################################################
'目录树对象初始化
'###################################################################################
Public Sub Clear_Tree_Node(p_Tree_Node As Tree_Defination)
   
   With p_Tree_Node
     .Data_Type = 0
     .Field_Cn_Name = ""
     .Field_En_Name = ""
     .Field_Value = ""
     .Is_Init = False
     .Is_Root = False
     .Node_ID = 0
     .Node_Level_Index = 0
     .Node_Type = 0
     .Parent_Node_ID = 0
     .System_Dict_Type = 0
     .Table_Name = ""
     .Tree_Name = ""
     .Tree_User_Name = ""
     .Type_Code = ""
     .View_List = False
     .Where_String = ""
   End With
   
End Sub

'###################################################################################
'日志记录函数
'pType日志类型 pObjectType对象类型 pTypeCode档案类型 pObjectNo对象id pRemark日志描述
'###################################################################################
Public Function SaveEventLog(pType As String, pObjectType As Integer, pTypeCode As String, pObjectNo As String, pRemark As String) As Boolean
On Error GoTo Err

SaveEventLog = True
Exit Function
Err:
   SaveEventLog = False
   
End Function

'#########################################################################
'显示文件列表
'参数：p_Node 选中的目录树节点 显示列表的控件
'返回：boolean 返回的值
'#########################################################################
Public Function List_View_File(p_Volume_List As ListView, p_ListCtl As ListView, p_Node As Node, SBarPanel1 As Panel, SBarPanel2 As Panel) As Boolean
On Error GoTo Err

Dim tSql As String '临时字串
Dim tListItem As ListItem '临时对象
Dim i As Integer '临时变量
Dim tRst '临时结果
Dim tNodeInfo As NodeInfo '节点对象

Dim tSystem_Dict_Type As Integer '数据字典类型
Dim tField_En_Name As String '节点显示的数据库字段名
Dim tField_Cn_Name As String '节点显示的数据库字段名
Dim tOrderStr As String 'Order字串
Dim tVolume_ID As String '案卷序列号
Dim tVolume_Status As String '案卷状态
Dim tKey As String '节点的Key
Dim tField_Value As String '节点字段在数据库中的值
Dim tTypeCode As String '文档类型
Dim tNodeID As String '节点ID
Dim tWhere_Str As String 'where子句
Dim tTable_Name As String '表名
Dim tFile_ID As String '文件ID
Dim tFileStatus As String '文件状态
Dim tList_Type As String '显示列表类型
Dim tIndex As String '节点或项目的Index

'清除已有数据
'p_ListCtl.ColumnHeaders.Clear
p_ListCtl.ListItems.Clear
p_ListCtl.Tag = ""

If p_Volume_List Is Nothing And p_Node Is Nothing Then GoTo Err

If Not (p_Volume_List Is Nothing) Then '选取某个卷下的文件,由单击卷列表触发
    
    tList_Type = "1" '选取某个卷下的文件,由单击卷列表触发 对应目录树列表
    
    If p_Volume_List.SelectedItem Is Nothing Then GoTo Err
    tIndex = CStr(p_Volume_List.SelectedItem.Index)
    '记录列表信息
    
    '设置变量
    Call GetValue(tVolume_ID, "Volume_id", p_Volume_List.SelectedItem.key)
    Call GetValue(tTypeCode, "type_code", p_Volume_List.SelectedItem.key)
    Call GetValue(tNodeID, "node_id", p_Volume_List.Tag)
    
    '文件列表控件
    p_ListCtl.Tag = p_Volume_List.Tag + _
                  " @VX " + tIndex + " @P " + tList_Type
    'Call GetValue(tNodeID, "node_id", p_ListCtl.Tag)
    
    tWhere_Str = "volume_id=" + tVolume_ID
    tTable_Name = "FILE_" + tTypeCode
    
ElseIf Not (p_Node Is Nothing) Then
  
    tList_Type = "2" '选取符合节点条件的文件，由单击节点触发 对应目录树列表
    
    If p_Node Is Nothing Then GoTo Err
    '设置变量