mdlfunction.bas

管理文档的原代码,可以把扫描的文档归类,便于查询

Attribute VB_Name = "MdlFunction"
Option Explicit

'####################################################################
'系统主函数
'####################################################################
Public Sub Main()
On Error GoTo Err
FrmSplash.Show
DoEvents

gErrDescription = ""
If App.PrevInstance Then
   MsgBox "文件管理客户端正在运行。不能多次启动！", vbOKOnly Or vbInformation, XTTS
   End
End If
Dim t As Boolean
t = LogonCheck("icbc", "icbctest", "icbc", 5, 0)
'Shell "net use \\develop2\test fengcz /user:fengcz"
'MsgBox Dir("c:\", vbDirectory)
If LoadReg = False Then
   If CreateReg = False Then GoTo Err
End If
If LoadReg = False Then GoTo Err
If CntDB = False Then End

FrmLogin.Show 1
If gLoginSuccess = False Then End

'Call KeepTime
gComputerName = GetComPuter
gTableSpace = "ICBCDOC"
gDiskCapacity = 620000000

FrmMain.Show
DoEvents
Call FrmMain.FrmInit
Call FrmMain.Mnu_View_Do_Click(0)
Call GetIEPath(g_IE_Path)
Call RemoveFile(App.Path + "\temp\*.*")
Call SaveEventLog("1007", 0, "", "", "用户登录")

If FrmSplash.Visible = True Then Unload FrmSplash

Exit Sub
Err:
   MsgErr "系统初始化", "1001", gErrDescription, True, LXGLY, Err.Description
   End
End Sub

'####################################################################
'系统统一时间，返回值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
Dim t As String

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

If RegGetString(HKEY_LOCAL_MACHINE, gRegSubKey + "\OPTION", "LVMainView", t) = False Then GoTo Err
gLVMainView = CInt(t)

If RegGetString(HKEY_LOCAL_MACHINE, gRegSubKey + "\OPTION", "MakeCDExe", gMakeCDExe) = False Then
   gMakeCDExe = "c:\smartstor archive\runfsapi.exe"
End If

LoadReg = True
Exit Function
Err:
   LoadReg = False
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

'If RegSetString(HKEY_LOCAL_MACHINE, gRegSubKey + "\OPTION", "ConvertDict", "") = False Then GoTo Err
If RegSetString(HKEY_LOCAL_MACHINE, gRegSubKey + "\OPTION", "LVMainView", "3") = False Then GoTo Err
If RegSetString(HKEY_LOCAL_MACHINE, gRegSubKey + "\OPTION", "MakeCDExe", "c:\smartstor archive\runfsapi.exe") = False Then GoTo Err
CreateReg = True
Exit Function
Err:
   CreateReg = False
End Function

'####################################################################
'数据库连接函数，返回值Boolean
'####################################################################
Public Function CntDB() As Boolean
On Error GoTo Err
Dim s As String
gErrDescription = ""
GblRdoCon.LoginTimeout = 5
'RDO连接
Set GblRdoEnv = rdoEnvironments(0)
GblRdoEnv.CursorDriver = rdUseClientBatch 'rdUseOdbc
Set GblRdoCon = GblRdoEnv.OpenConnection("", rdDriverNoPrompt, False, "dsn=" + gDSN + ";uid=" + gUserID + ";pwd=" + gPwd)

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

'####################################################################
'系统报错函数，返回值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

'#########################################################################
'删除字符串中首、尾字串
'参数：pOrgString原始字符串 pRemoveString 要删除的字符串
'     pRemoveType 删除方式 0首尾都要删除 1首删除 2尾删除
'返回Boolean 调用FrmMain
'#########################################################################
Public Function RemoveString(pOrgString As String, pRemoveString As String, pRemoveType As Integer) As String
On Error GoTo Err
Dim tStrLen As Integer '删除的字符串长度
pOrgString = Trim(pOrgString)
RemoveString = pOrgString
RemoveString = Trim(pOrgString)
tStrLen = Len(pRemoveString)

If pRemoveType = 0 Or pRemoveType = 1 Then '首删除
   If Mid(pOrgString, 1, tStrLen) = pRemoveString Then RemoveString = Mid(pOrgString, tStrLen + 1)
End If
If pRemoveType = 0 Or pRemoveType = 2 Then '尾删除
   If Right(pOrgString, tStrLen) = pRemoveString Then RemoveString = Mid(pOrgString, 1, Len(pOrgString) - tStrLen)
End If

Exit Function
Err:
   RemoveString = pOrgString
End Function

'###################################################################################
'空字符串转换
'###################################################################################
Public Function ConvertNull(p_Field_Value As Variant) As String
On Error GoTo Err
If IsNull(p_Field_Value) = True Then GoTo Err
ConvertNull = CStr(p_Field_Value)
Exit Function
Err:
  ConvertNull = ""
End Function

'###################################################################################
'关闭数据库全局变量对象
'###################################################################################
Public Sub CloseDB()
On Error GoTo Err

If Not (GblRdoRes Is Nothing) Then GblRdoRes.Close
If Not (GblRdoCon Is Nothing) Then GblRdoCon.Close
Err:
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

GblRdoCon.Execute "insert into eventlog (event_id,type,operator,operate_time,object_type,type_code,object_no,remark) values(" & _
  "seq_event.nextval,'" + pType + "','" + g_User_Info.Login_Name + "',sysdate," & _
  CStr(pObjectType) + ",'" + pTypeCode + "','" + pObjectNo + "','" + pRemark + "')"
SaveEventLog = True
Exit Function
Err:
   SaveEventLog = False
   
End Function

'#########################################################################
'字段数值转换
'参数：pOrg_Value要转换的数值 pData_Type转换值的类型 pIs_In_Where 是否在查询语句中 pPermit_Null 是否允许为空
'     pConvertType转换类型 0 pData_Type为数据库中的数据类型 1pData_Type为自定义的数据类型
'返回：String 返回的值
'#########################################################################
Public Function Convert_Value(pOrg_Value As Variant, pConvertType As Integer, pData_Type As Integer, pIs_In_Where As Boolean, pPermit_Null As Boolean) As String
On Error GoTo Err
Dim tData_Type As Integer '1日期,2字符,3数字
Dim tDate As Date

'如果为空
If IsNull(pOrg_Value) = True Then
    If pPermit_Null = True Then
       Convert_Value = "NULL"
    ElseIf pPermit_Null = False Then
       If (pConvertType = 0 And pData_Type = 3) Or (pConvertType = 1 And pData_Type = 4) Then
          Convert_Value = "0"
       ElseIf (pConvertType = 1 And pData_Type = 1) Or (pConvertType = 0 And pData_Type = 11) Then
          Convert_Value = Format(Date, "yyyy-mm-dd")
       Else
          Convert_Value = ""
       End If
    End If
    Exit Function
End If

'获取字段类型
If pConvertType = 0 Then
    Select Case pData_Type 'pData_Type为数据库中的数据类型
       Case 11 '日期
          tData_Type = 1
       Case 3 '数字
          tData_Type = 3
       Case 1, 12 '字符
          tData_Type = 2
       Case Else
          MsgBox "数据类型" + CStr(pData_Type)
   End Select
   
ElseIf pConvertType = 1 Then
   Select Case pData_Type 'pData_Type为自定义的数据类型
       Case 1 '日期
          tData_Type = 1
       Case 2, 3 '字符
          tData_Type = 2
       Case 4 '数字
          tData_Type = 3
   End Select
End If

Select Case tData_Type
   Case 1 '日期
       '日期转换
       If Len(CStr(pOrg_Value)) = 8 And InStr(1, CStr(pOrg_Value), "-") And InStr(1, CStr(pOrg_Value), "/") <> 0 And InStr(1, CStr(pOrg_Value), "\") <> 0 Then
          pOrg_Value = Mid(pOrg_Value, 1, 4) + "/" + Mid(pOrg_Value, 5, 2) + "/" + Mid(pOrg_Value, 7, 2)
       ElseIf IsDate(pOrg_Value) = True Then
          Convert_Value = Format(pOrg_Value, "yyyy-mm-dd")
       Else
          If pPermit_Null Then GoTo Err
          Convert_Value = Format(Date, "yyyy-mm-dd")
       End If
   Case 2, 3 '字符'数值
       Convert_Value = Trim(CStr(pOrg_Value))
End Select

If pIs_In_Where Then
    Select Case tData_Type
       Case 1 '日期
          Convert_Value = "TO_DATE('" + Convert_Value + "','YYYY\MM\DD')"
       Case 2 '字符'
           Convert_Value = "'" + Convert_Value + "'"
       Case 3 '数值
    
    End Select
End If
Exit Function
Err:
   If pPermit_Null = True Then
      Convert_Value = "NULL"
   Else
      Convert_Value = ""
   End If
End Function

' "Software\方正奥德计算机系统有限公司\SystemManage\"
Public Function GetRegVal(SubKey As String, RtnString As String) As Boolean
On Error GoTo Err