mdlformat.bas

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

Attribute VB_Name = "MdlFormat"

'#########################################################################
'数据字典转换,自定义数据转换
'参数：p_Type数据字典中的代码类型 pField_Value要转换的值 可以是code 或code对应的值
'     pSystem_Dict_Type数据字典代码,pField_Name字段名,pTable_Type 0案卷表1文件表2用户表
'     pConvertType转换类型 0代码->值 1值->代码
'返回：String 返回的值
'#########################################################################
Public Function ConvertFieldValue(pField_Value As Variant, pSystem_Dict_Type As Integer, pField_Name As String, pTable_Type As Integer) As String
On Error GoTo Err
Dim tRst
Dim tStr As String
tStr = ConvertNull(pField_Value)
If pSystem_Dict_Type <> 0 Then
   If gConvert_To_Dict = True Then
      ConvertFieldValue = Trim(Convert_Dict_Value(pSystem_Dict_Type, tStr, 0))
   Else
      GoTo Err
   End If
   Exit Function
End If
If pTable_Type = 0 Then '案卷表
    Select Case UCase(pField_Name)
       Case "TYPE_CODE" '档案类型
         Set tRst = gDbs.OpenRecordset("select TYPE_NAME from ARCHIVE_TYPE where TYPE_CODE='" + tStr + "'")
         If tRst.EOF Then GoTo Err
         ConvertFieldValue = tRst.Fields(0)
       Case "TYPE" '组卷类型
         If tStr = "0" Then
           ConvertFieldValue = "案卷"
         ElseIf tStr = "0" Then
           ConvertFieldValue = "档案盒"
         End If
       Case "BORROW_STATUS"
         If tStr = "0" Then
           ConvertFieldValue = "未借阅"
         ElseIf tStr = "1" Then
           ConvertFieldValue = "实物已借阅"
         ElseIf tStr = "2" Then
           ConvertFieldValue = "已还"
         End If
       Case "TRANSFER_FLAG"
         If tStr = "0" Then
           ConvertFieldValue = "未移交"
         ElseIf tStr = "1" Then
           ConvertFieldValue = "已移交"
         End If
       Case "DESTRUCTION_FLAG"
         If tStr = "0" Then
           ConvertFieldValue = "未销毁"
         ElseIf tStr = "1" Then
           ConvertFieldValue = "已销毁"
         End If
       Case "STATUS"
         If tStr = "0" Then
           ConvertFieldValue = "未归档"
         ElseIf tStr = "1" Then
           ConvertFieldValue = "已归档"
         ElseIf tStr = "2" Then
           ConvertFieldValue = "暂组卷"
         ElseIf tStr = "3" Then
           ConvertFieldValue = "已封卷"
         ElseIf tStr = "4" Then
           ConvertFieldValue = "暂组盒"
         ElseIf tStr = "5" Then
           ConvertFieldValue = "已封盒"
         End If
       Case Else
         GoTo Err
    
    End Select
ElseIf pTable_Type = 2 Then
    If UCase(pField_Name) = "USER_ID" Then
         Set tRst = gDbs.OpenRecordset("select user_name from user_table where user_id=" + tStr)
         If tRst.EOF Then GoTo Err
         ConvertFieldValue = tRst.Fields(0)
    Else
         GoTo Err
    End If
ElseIf pTable_Type = 2 Then
    If UCase(pField_Name) = "RIGHTS" Then
       If tStr = "1" Then
          ConvertFieldValue = "可查看"
       ElseIf tStr = "2" Then
          ConvertFieldValue = "可打印"
       ElseIf tStr = "3" Then
          ConvertFieldValue = "可修改"
       ElseIf tStr = "0" Then
          ConvertFieldValue = "无权限"
       End If
    Else
       GoTo Err
    End If
Else
    GoTo Err

End If

Exit Function
Err:
   ConvertFieldValue = tStr
End Function

'#########################################################################
'数据字典转换
'参数：p_Type数据字典中的代码类型 pOrg_Value要转换的值 可以是code 或code对应的值
'     pConvertType转换类型 0代码->值 1值->代码
'返回：String 返回的值
'#########################################################################
Public Function Convert_Dict_Value(p_Type As Integer, pOrg_Value As String, pConvertType As Integer) As String
On Error GoTo Err
Dim tRst
If p_Type = 0 Or gConvert_To_Dict = False Then GoTo Err

'0代码->值
If pConvertType = 0 Then
'   Set tRst = gDbs.OpenRecordset("select name from system_dict where int(code)=" + Trim(pOrg_Value) + " and type=" + CStr(p_Type))
'   If tRst.EOF Then GoTo Err
   If IsControl(FrmMain.LVDict(p_Type)) = False Then Call FrmMain.AddDict(p_Type)
   Set tItem = FrmMain.LVDict(p_Type).FindItem(Trim(pOrg_Value), lvwText, , lvwPartial)
   If tItem Is Nothing Then GoTo Err
   Convert_Dict_Value = tItem.SubItems(1) '1值->代码
ElseIf pConvertType = 0 Then
   Set tRst = gDbs.OpenRecordset("select code from system_dict where name='" + pOrg_Value + "' and type=" + CStr(p_Type))
   If tRst.EOF Then GoTo Err
   Convert_Dict_Value = tRst.Fields(0)
Else
   GoTo Err
End If
Exit Function
Err:
   Convert_Dict_Value = pOrg_Value
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 8 '日期
          tData_Type = 1
       Case 4, 6 '数字
          tData_Type = 3
       Case 10, 12 '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 = "#" + Convert_Value + "#"
       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

'#########################################################################
'增加 Where子句
'参数：pWhereStr1原句 pWhereStr1 要增加的子句
'返回pWhereStr1 增加后的子句
'#########################################################################
Public Function AddWhereStr(pWhereStr1 As String, pWhereStr2 As String) As Boolean
On Error GoTo Err
pWhereStr1 = Trim(pWhereStr1)
pWhereStr2 = Trim(pWhereStr2)
If pWhereStr1 <> "" And pWhereStr2 <> "" Then
   pWhereStr1 = " (" + pWhereStr1 + ") and (" + pWhereStr2 + ") "
ElseIf pWhereStr1 <> "" Then
   pWhereStr1 = pWhereStr1
ElseIf pWhereStr2 <> "" Then
   pWhereStr1 = pWhereStr2
End If

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

'#########################################################################
'删除字符串中首、尾字串
'参数：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)
pRemoveString = Trim(pRemoveString)
tStrLen = Len(pRemoveString)
RemoveString = pOrgString
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

'#########################################################################
'获取关键字中的信息
'参数：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

'#########################################################################
'获取文件或案卷状态信息
'参数：p_Type 0文件 1案卷 pOrgString 状态字串 pKeyWord 要读取的信息
'返回String 返回值
'#########################################################################
Public Function GetStatus(p_Type As Integer, pOrgString As String, pKeyWord As String) As String
On Error GoTo Err
'文件状态+移交标志+销毁标志+借阅状态
'卷盒标志+组卷标志+移交标志+销毁标志
If p_Type = 0 Then '文件
   Select Case UCase(pKeyWord)
      Case "STATUS"
         GetStatus = Mid(pOrgString, 1, 1)
      Case "TRANSFER_FLAG"
         GetStatus = Mid(pOrgString, 2, 1)
      Case "DESTRUCTION_FLAG"
         GetStatus = Mid(pOrgString, 3, 1)
      Case "BORROW_STATUS"
         GetStatus = Mid(pOrgString, 4, 1)
   End Select
ElseIf p_Type = 1 Then '案卷
   Select Case UCase(pKeyWord)
      Case "TYPE"
         GetStatus = Mid(pOrgString, 1, 1)
      Case "STATUS"
         GetStatus = Mid(pOrgString, 2, 1)
      Case "TRANSFER_FLAG"
         GetStatus = Mid(pOrgString, 3, 1)
      Case "DESTRUCTION_FLAG"
         GetStatus = Mid(pOrgString, 4, 1)
   End Select
Else
    GoTo Err
End If
Exit Function
Err:
   GetStatus = ""
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 = Trim(CStr(p_Field_Value))
Exit Function
Err:
  ConvertNull = ""
End Function

'获取档案组织类型
Public Function GetOrgType(ByVal pTypeCode As String, rOrgType As Integer) As Boolean
On Error GoTo Err
Dim tRdoRes
Set tRdoRes = gDbs.OpenRecordset("select org_type from Archive_Type where Type_Code ='" + UCase(Trim(pTypeCode)) + "'")
If tRdoRes.EOF Then GoTo Err
rOrgType = tRdoRes.Fields("org_type")
GetOrgType = True
Exit Function
Err:
GetOrgType = False
End Function

'是否有相应对象
Public Function HasObject(ByVal pTypeCode As String, ByVal pObjectType As Integer) As Boolean
On Error GoTo Err
Dim tOrgType As Integer
If GetOrgType(pTypeCode, tOrgType) = False Then GoTo Err
Select Case pObjectType
   Case 1 '文件
      If tOrgType = 1 Then GoTo Err
   Case 2 '案卷
      If tOrgType = 0 Or tOrgType = 2 Then GoTo Err
   Case 3 '盒
      If tOrgType = 0 Or tOrgType = 1 Or tOrgType = 3 Then GoTo Err
End Select
HasObject = True
Exit Function
Err:
   HasObject = False
End Function