mdlfunction.bas

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

Dim Reg_Size As Long
Dim Reg_buffer As String
Dim Reg_Result As Long
Reg_buffer = String$(1024, 0)
Reg_Size = 1024
Reg_Result = RegQueryValue(HKEY_LOCAL_MACHINE, SubKey, Reg_buffer, Reg_Size)
If Reg_Result <> 0 And Reg_Result <> 13 Then GoTo Err
If InStr(1, Reg_buffer, ";") <= 1 Then
   RtnString = Left(Trim(Reg_buffer), Reg_Size - 1)
Else
   RtnString = Left(Trim(Reg_buffer), InStr(1, Reg_buffer, ";") - 1)
End If
GetRegVal = True
Exit Function
Err:
   GetRegVal = False
End Function

'#####################################################################################
'获取系统路径
'#####################################################################################
Public Function GetSysPath() As String
On Error GoTo ErrHandle
Dim lngResult As Long
Dim lpBuffer$
Dim StrGetWin As String
lpBuffer = Space$(2048)
lngResult = GetWindowsDirectory(lpBuffer, Len(lpBuffer))
StrGetWin = Left(Trim(lpBuffer), Len(Trim(lpBuffer)) - 1)
GetSysPath = StrGetWin
Exit Function
ErrHandle:
   MsgBox "系统错误" + Chr(10) + "错误描述：" + Err.Description
End Function

'#####################################################################################
'获取IE路径
'#####################################################################################
Public Function GetIEPath(r_IE_Path As String) As Boolean
On Error GoTo Err
r_IE_Path = ""

If RegGetString(HKEY_LOCAL_MACHINE, "Software\Microsoft\IE4\Setup", "Path", r_IE_Path) = False Then GoTo Err
r_IE_Path = Replace(r_IE_Path, "%programfiles%", "c:\program files")
If Dir(r_IE_Path + "\Iexplore.exe") = "" Then GoTo Err
r_IE_Path = r_IE_Path + "\Iexplore.exe"
GetIEPath = True
Exit Function
Err:
   r_IE_Path = ""
   GetIEPath = False
End Function

'#####################################################################################
'清除临时文件
'#####################################################################################
Public Sub RemoveFile(p_Path As String)
On Error GoTo Err
Kill p_Path
Err:
End Sub

'#####################################################################################
'目录是否存在
'#####################################################################################
Public Function DirectoryAvailable(pPath As String) As Boolean
On Error GoTo Err
If Dir(RemoveString(pPath, "\", 2) + "\", vbDirectory) = "" Then GoTo Err

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

'#####################################################################################
'创建新目录
'#####################################################################################
Public Function CreateNewDir(pPath As String) As Boolean
On Error GoTo Err

MkDir pPath
CreateNewDir = True
Exit Function
Err:
   CreateNewDir = False
End Function

'#########################################################################
'获取关键字中的信息
'参数：RtnValue返回值 KeyWord 要读取的信息 Node_Key 关键字
'返回Boolean 调用FrmMain
'#########################################################################
Public Function GetValue(RtnValue As String, KeyWord As String, Node_Key As String) As Boolean
On Error GoTo Err
Dim FindStr As String
Dim StartPos As Integer
Dim StartPos2 As Integer
RtnValue = ""
Select Case UCase(KeyWord)
   Case "WHERE" '查询子句
       FindStr = "@W"
   Case "ORDER" '排序子句
       FindStr = "@O"
   Case "NODE_ID", "VOLUME_ID", "FILE_ID", "ID" '对象序列号
       FindStr = "@I"
   Case "FIELD_EN_NAME", "FIELD_NAME" '数据库中子段名称
       FindStr = "@F"
   Case "TABLE_NAME" '表名
       FindStr = "@T"
   Case "VALUE" '子段的值
       FindStr = "@V"
   Case "CATALOGNO"
       FindStr = "@C"
   '文件状态+移交标志+销毁标志+借阅状态
   '卷盒标志+组卷标志+移交标志+销毁标志
   Case "STATUS"
       FindStr = "@S"
   Case "VIEW_LIST" '显示列表类型
       FindStr = "@L"
   Case "DICT_TYPE" '数据字典类型
       FindStr = "@D"
   Case "TYPE_CODE", "TYPE", "DATA_TYPE" '档案类型,显示类型,数据类型
       FindStr = "@P"
   Case "INDEX" '节点索引值
       FindStr = "@X"
   Case "VOLUME_INDEX" '节点索引值
       FindStr = "@VX"
   Case "NODE_INDEX" '节点索引值
       FindStr = "@NX"
   Case "IS_NULL" '字段是否允许为空
       FindStr = "@N"
   Case "IS_DEFINED" '字段是否为自定义
       FindStr = "@DF"
   Case "1", "2", "3", "4", "5", "6"
       FindStr = "@" + KeyWord
   Case Else
       MsgBox UCase(KeyWord)
End Select

StartPos = InStr(1, Node_Key, FindStr)
If StartPos <> 0 Then
   StartPos2 = InStr(StartPos + 1, Node_Key, "@")
   If StartPos2 <> 0 Then
      RtnValue = Mid(Node_Key, StartPos + Len(FindStr), StartPos2 - StartPos - Len(FindStr))
   Else
      RtnValue = Mid(Node_Key, StartPos + Len(FindStr))
   End If
Else
   GoTo Err
End If
RtnValue = Trim(RtnValue)
GetValue = True
Exit Function
Err:
   GetValue = False
   RtnValue = ""
End Function

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

'如果为空
If IsNull(pOrg_Value) = True Then
   GetValueStr = "NULL"
   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
   
'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
          GetValueStr = Format(pOrg_Value, "yyyy-mm-dd")
       Else
          'If pPermit_Null Then GoTo Err
          GetValueStr = Format(Date, "yyyy-mm-dd")
       End If
       GetValueStr = "'" + GetValueStr + "'"
   Case 2 '字符
       GetValueStr = Trim(CStr(pOrg_Value))
       GetValueStr = "'" + GetValueStr + "'"
   Case 3  '数值
       GetValueStr = Trim(CStr(pOrg_Value))
End Select

Exit Function
Err:
   'If pPermit_Null = True Then
      GetValueStr = "NULL"
   'Else
   '   GetValueStr = ""
   'End If
End Function

'#####################################################################################
'创建文件夹 pRoot根路径， pPath为相对路径
'#####################################################################################
Public Function CreateDir(ByVal pRoot As String, ByVal pPath As String) As Boolean
On Error GoTo Err
Dim tPos As Integer
Dim tRoot As String
Dim tPath As String
tRoot = RemoveString(pRoot, "\", 2)
tPath = RemoveString(pPath, "\", 0)

tPos = InStr(tPos + 1, pPath, "\")
Do While Not tPos = 0
   If Dir(tRoot + "\" + Mid(tPath, 1, tPos - 1) + "\", vbDirectory) = "" Then MkDir (tRoot + "\" + Mid(tPath, 1, tPos - 1))
   tPos = InStr(tPos + 1, tPath, "\")
Loop
If Dir(tRoot + "\" + tPath + "\", vbDirectory) = "" Then MkDir tRoot + "\" + tPath

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

'#####################################################################################
'获取指定根路径id 的绝对路径
'#####################################################################################
Public Function GetRootPath(pRootID As String) As String
On Error GoTo Err
Dim tRdoRes As rdoResultset

Set tRdoRes = GblRdoCon.OpenResultset("select root_path from root_table where root_id=" + pRootID, rdOpenDynamic, rdConcurRowVer)
If tRdoRes.EOF Then GoTo Err
GetRootPath = Trim(RemoveString(ConvertNull(tRdoRes.rdoColumns("root_path")), "\", 2))
Exit Function
Err:
   GetRootPath = ""
End Function

'#####################################################################################
'路径是否存在
'#####################################################################################
Public Function RootAvailable(pRootPath As String) As Boolean
On Error GoTo Err
If Dir(pRootPath + "\", 31) = "" Then GoTo Err
RootAvailable = True
Exit Function
Err:
   RootAvailable = False
End Function

'#####################################################################################
'删除路径
'#####################################################################################
Public Sub DelDir(pDirPath As String)
On Error GoTo Err
Dim fs As FileSystemObject
'DelDir "e:\makedisk\sdi\test"

Dim f As File
Dim fd As Folder

pDirPath = RemoveString(pDirPath, "\", 2)

If Len(pDirPath) < 4 Then
   If MsgBox("您确认要删除路径" + pDirPath + "，是否终止", vbQuestion + vbYesNo, XTTS) = vbYes Then Exit Sub
End If

Set fs = CreateObject("Scripting.FileSystemObject")
Call RemoveFile(pDirPath + "\*.*")
For Each fd In fs.GetFolder(pDirPath).SubFolders
    Call DelDir(fd.Path)
Next
'Set fd = fs.GetFolder(pDirPath)
'fd.Delete True '
RemoveDirectory pDirPath
Exit Sub
Err:
   MsgBox Err.Description
End Sub