frmmakedisk.frm

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

'       MsgBox "没有数据类型" + CStr(.Type) + " name:" + .Name
'    Case -3 'rdTypeVARBINARY -3 可变长度的二进制数据。最大长度为 255。
'       MsgBox "没有数据类型" + CStr(.Type) + " name:" + .Name
'
'    Case -4 'rdTypeLONGVARBINARY -4 可变长度的二进制数据。最大长度依赖于数据源。
'       MsgBox "没有数据类型" + CStr(.Type) + " name:" + .Name
'
'    Case -5 'rdTypeBIGINT -5 带符号的、精确的、带有精度为 19（带符号）或 20（无符号），比例为 0，（带符号：-263 ≤ n ≤ 263-1，无符号：0 ≤ n ≤ 264-1）的数字值。
'       MsgBox "没有数据类型" + CStr(.Type) + " name:" + .Name
'
'    Case -6 'rdTypeTINYINT -6 带符号的、精确的、带有精度为 3，比例为 0 的数字值，（带符号： -128 ≤ n ≤ 127，无符号：0 ≤ n ≤ 255）。
'       MsgBox "没有数据类型" + CStr(.Type) + " name:" + .Name
'
'    Case -7 'rdTypeBIT -7 单个二进制数字。
'       MsgBox "没有数据类型" + CStr(.Type) + " name:" + .Name

  End Select
  
  If .Required = True Then rStr = rStr + " not null"

  rStr = rStr + ","
  
  '.SourceColumn
End With
GetCreateStr = True
Exit Function
Err:
   GetCreateStr = False
End Function

'#####################################################################################
'连接Access表 pFilePath Access表的文件路径
'#####################################################################################
Public Function CntDiskDB(pFilePath As String) As Boolean
On Error GoTo Err
Set gWrks = DBEngine.CreateWorkspace("", "admin", "")
Set gAccessDbs = gWrks.OpenDatabase(pFilePath)
Set gOrclDbs = gWrks.OpenDatabase(gDSN, dbDriverNoPrompt, False, "ODBC" + ";dsn=" + gDSN + ";uid=" + gUserID + ";pwd=" + gPwd)

CntDiskDB = True
Exit Function
Err:
   CntDiskDB = True
End Function

'#####################################################################################
'根据查询文件导入业务数据 pFilePath查询文件路径
'#####################################################################################
Public Function ImportToAccess(pFilePath As String) As Boolean
On Error GoTo Err
Dim tQueryStr As String
Dim tTableName As String
Dim tWhereStr As String
Dim tSqlStr As String
Dim tStr As String

Call FrmLoadQueryFile.FrmInit(pFilePath, False)
If FrmLoadQueryFile.LoadQueryFile(pFilePath) = False Then GoTo Err
If FrmLoadQueryFile.GetQueryStr(tQueryStr, tTableName, tWhereStr) = False Then GoTo Err

'备份盘
If TxtDiskType = "2" Then tQueryStr = tQueryStr + " and is_backuped=0"

'导入数据
If ImportData(tQueryStr, tTableName, PBar(4)) = False Then GoTo Err

'导入相关对象数据
If CheckAll.Value = 1 Then
   If InStr(1, LCase(tTableName), "file") <> "" Then '文件表
      tStr = "volume_" + Mid(tTableName, 6)
      tSqlStr = "select * from " + tStr + " where volume_id in (select distinct(volume_id) from " + tTableName + " where " + tWhereStr + ")"
   ElseIf InStr(1, LCase(tTableName), "volume") <> "" Then '案卷表
      tStr = "file_" + Mid(tTableName, 8)
      tSqlStr = "select * from " + tStr + " where volume_id in (select volume_id from " + tTableName + " where " + tWhereStr + ")"
   End If
   If ImportData(tSqlStr, tStr, PBar(4)) = False Then GoTo Err
End If

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

'#####################################################################################
'导入指定表数据 pQueryStr要导入数据的select语句 pTableName要导入的表名称 pBar要显示的进度控件
'#####################################################################################
Public Function ImportData(pQueryStr As String, pTableName As String, PBar As ProgressBar) As Boolean
On Error GoTo Err
Dim tRdoRes As rdoResultset
Dim i As Integer
Dim tFieldStr As String
Dim tValueStr As String
Dim IsFileTable As Boolean
Dim IsVolumeTable As Boolean
Dim tRst As Recordset
Dim RecordExist As Boolean
Dim tTypeCode As String

If InStr(1, UCase(pTableName), "FILE_") <> 0 And UCase(pTableName) <> "FILE_RIGHT" Then
   If LCase(Mid(pTableName, 1, 5)) = "file_" Then
      IsFileTable = True
      tTypeCode = Mid(pTableName, 6)
   End If
End If

If InStr(1, UCase(pTableName), "VOLUME_") <> 0 Then
   If LCase(Mid(pTableName, 1, 7)) = "volume_" Then
      IsVolumeTable = True
      tTypeCode = Mid(pTableName, 8)
   End If
End If

Set tRdoRes = GblRdoCon.OpenResultset(pQueryStr, rdOpenDynamic, rdConcurRowVer)
If Not (tRdoRes.EOF) Then
   '获取field字段
   tFieldStr = ""
   For i = 0 To tRdoRes.rdoColumns.Count - 1
      tFieldStr = tFieldStr + tRdoRes.rdoColumns(i).Name + ","
   Next i
   tFieldStr = " (" + RemoveString(tFieldStr, ",", 2) + ") "
   
   '组合value字串
   While Not tRdoRes.EOF
      RecordExist = False
      PBar.Value = tRdoRes.AbsolutePosition / tRdoRes.RowCount * 100
      DoEvents
      tValueStr = ""
      For i = 0 To tRdoRes.rdoColumns.Count - 1
          tValueStr = tValueStr + GetValueStr(tRdoRes.rdoColumns(i), tRdoRes.rdoColumns(i).Type) + ","
          If IsFileTable = True And UCase(tRdoRes.rdoColumns(i).Name) = "FILE_ID" Then
             '检查数据是否已经导入
             Set tRst = gAccessDbs.OpenRecordset("select * from " + pTableName + " where file_id=" + CStr(tRdoRes.rdoColumns(i)) + ";")
             If Not (tRst.EOF) Then
                RecordExist = True
                Exit For
             End If
          End If
          If IsVolumeTable = True And UCase(tRdoRes.rdoColumns(i).Name) = "VOLUME_ID" Then
             '检查数据是否已经导入
             Set tRst = gAccessDbs.OpenRecordset("select * from " + pTableName + " where volume_id=" + CStr(tRdoRes.rdoColumns(i)) + ";")
             If Not (tRst.EOF) Then
                RecordExist = True
                Exit For
             End If
          End If
      Next i
      tValueStr = " values(" + RemoveString(tValueStr, ",", 2) + ") "
      
      '插入记录
      If RecordExist = False Then gAccessDbs.Execute "insert into " + pTableName + tFieldStr + tValueStr + ";"
      tRdoRes.MoveNext
   Wend
   
   '是文件或案卷表 将Access表Root字段置为空
   If IsVolumeTable = True Or IsFileTable = True Then
      gAccessDbs.Execute "update file_" + tTypeCode + " set root_id=NULL"
   End If
   'ElseIf IsFileTable = True Then '文件表
   
   'End If
End If
PBar.Value = 100
ImportData = True
Exit Function
Err:
   ImportData = False
End Function

'#####################################################################################
'根据查询文件移动文件 pFilePath查询文件的绝对路径
'#####################################################################################
Public Function MoveDir(pFilePath As String) As Boolean
On Error GoTo Err
Dim tQueryStr As String
Dim tTableName As String
Dim tWhereStr As String

Call FrmLoadQueryFile.FrmInit(pFilePath, False)
If FrmLoadQueryFile.LoadQueryFile(pFilePath) = False Then GoTo Err
If FrmLoadQueryFile.GetQueryStr(tQueryStr, tTableName, tWhereStr) = False Then GoTo Err

'备份盘
If TxtDiskType = "2" Then tWhereStr = tWhereStr + " and is_backuped=0"

'导入数据
If MoveSelDir(tQueryStr, tTableName, tWhereStr, PBar(6)) = False Then GoTo Err

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

'#####################################################################################
'移动所选文件至硬盘虚拟光盘下（备份或编研目录） pQueryStr所选对象的select语句 pWhereStr select语句中的where子句 pBar显示进度的控件
'#####################################################################################
Public Function MoveSelDir(pQueryStr As String, pTableName As String, pWhereStr As String, PBar As ProgressBar) As Boolean
On Error GoTo Err

Dim tRdoRes As rdoResultset
Dim i As Integer
Dim j As Integer
Dim IsFileTable As Boolean
Dim IsVolumeTable As Boolean
Dim tStr As String
Dim tTypeCode As String
Dim tDir As String
Dim tDirSize As Long

If InStr(1, UCase(pTableName), "FILE_") <> 0 Then
   tTypeCode = Mid(pTableName, 6)
   IsFileTable = True
   tStr = pQueryStr
End If

If InStr(1, UCase(pTableName), "VOLUME_") <> 0 Then
   tTypeCode = Mid(pTableName, 8)
   tStr = "select * from file_" + tTypeCode + " where volume_id in (select volume_id from " + pTableName + " where " + pWhereStr + ")"
   IsVolumeTable = True
End If

GblRdoCon.BeginTrans
    Set tRdoRes = GblRdoCon.OpenResultset(tStr, rdOpenDynamic, rdConcurRowVer)
    If Not (tRdoRes.EOF) Then
       While Not tRdoRes.EOF
          PBar.Value = tRdoRes.AbsolutePosition / tRdoRes.RowCount * 100
          Label2(5).Caption = "进度：" + Format(tRdoRes.AbsolutePosition / tRdoRes.RowCount, "0.00%")
          DoEvents
          '有电子文件
          If ConvertNull(tRdoRes.rdoColumns("path")) <> "" Then
             tDir = GetRootPath(ConvertNull(tRdoRes.rdoColumns("root_id")))
             If tDir = "" Then GoTo Err
             If CreateDir(Me.Tag, ConvertNull(tRdoRes.rdoColumns("path"))) = False Then GoTo Err
             '???????????????出错
             
             Call MoveFileEx(tDir, Me.Tag, ConvertNull(tRdoRes.rdoColumns("path")), gDiskSize)
             If gDiskSize > gDiskCapacity Then GoTo Err
          End If
          tRdoRes.MoveNext
       Wend
       
       '修改数据库
       If TxtDiskType = "2" Then '备份
          gAccessDbs.Execute "update file_" + tTypeCode + " set root_id=1,is_backuped=1"
          If IsVolumeTable = True Then
             GblRdoCon.Execute "update file_" + tTypeCode + " set root_id=" + TxtRootID + ",is_backuped=1 where volume_id in (select volume_id from " + pTableName + " where " + pWhereStr + ")"
             GblRdoCon.Execute "update volume_" + tTypeCode + " set is_backuped=1 where " + pWhereStr
             'gAccessDbs.Execute "update volume_" + tTypeCode + " set is_backuped=1 where " + pWhereStr
          Else
             GblRdoCon.Execute "update file_" + tTypeCode + " set root_id=" + TxtRootID + ",is_backuped=1 where " + pWhereStr
          End If
       ElseIf TxtDiskType = "3" Then '编研
          gAccessDbs.Execute "update file_" + tTypeCode + " set root_id=1"
       End If
    End If
GblRdoCon.CommitTrans
PBar.Value = 100
MoveSelDir = True
Exit Function
Err:
   MsgBox "您整理的光盘容量已经超出最大限制，系统终止", vbExclamation, XTTS
   MoveSelDir = False
End Function

'#####################################################################################
'移动指定目录下的文件 pSrcRoot源路径 pDesRoot目标路径 pPath相对路径 rDesDirSize返回的目录大小
'#####################################################################################
Public Function MoveFileEx(pSrcRoot As String, pDesRoot As String, pPath As String, rDesDirSize As Long) As Boolean
On Error GoTo Err
Dim fs As FileSystemObject
Dim fd As Folder
Dim fd2 As Folder
'?????????????若档案编研出错时，是否可以继续进行
Dim f As File
Set fs = CreateObject("Scripting.FileSystemObject")
Set fd = fs.GetFolder(pSrcRoot + "\" + pPath)
Set fd2 = fs.GetFolder(pDesRoot + "\" + pPath)

If fd.Path <> fd2.Path Then '若源路径和目标路径相同则跳过
   rDesDirSize = rDesDirSize + fd.Size - fd2.Size
   If rDesDirSize > gDiskCapacity Then GoTo Err
   Call RemoveFile(pDesRoot + "\" + pPath + "\*.*")
   fs.CopyFile pSrcRoot + "\" + pPath + "\*.*", pDesRoot + "\" + pPath + "\"
End If
MoveFileEx = True
Exit Function
Err:
   MoveFileEx = False
End Function

'#####################################################################################
'复制指定的access表名的索引 pTableName指定的access表名
'#####################################################################################
Public Function CreateIndex(pTableName As String) As Boolean
On Error GoTo Err

Dim tAccessTdf As TableDef
Dim tOrclTdf As TableDef
Dim idxNew As Index
Dim idxLoop As Index
Dim i As Integer
Dim j As Integer

Set tAccessTdf = gAccessDbs.TableDefs(pTableName)
Set tOrclTdf = gOrclDbs.TableDefs(pTableName)

For i = 0 To tOrclTdf.Indexes.Count - 1
    Set idxNew = tAccessTdf.CreateIndex(tOrclTdf.Indexes(i).Name)
    For j = 0 To tOrclTdf.Indexes(i).Fields.Count - 1
        idxNew.Fields.Append idxNew.CreateField(tOrclTdf.Indexes(i).Fields(j).Name)
    Next j
    tAccessTdf.Indexes.Append idxNew
Next i

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