frmmakedisk.frm

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

Option Explicit
'DAO变量
Public gWrks As Workspace
Public gAccessDbs As Database
Public gOrclDbs As Database
Public gDiskSize As Long '纪录所整理光盘的大小

Private Sub CmdCancel_Click()
Unload Me
End Sub

Private Sub CmdOK_Click()
Dim tFileName As String
On Error GoTo Err
Dim fs As FileSystemObject
Dim fd As Folder
Dim tfile As File
Dim tFileCount As Integer '文件个数
Dim i As Integer
Me.Enabled = False
Set fs = CreateObject("Scripting.FileSystemObject")

''删除当前目录中子目录
'For Each fd In fs.GetFolder(Me.Tag).SubFolders
'   fd.Delete True
'Next

tFileName = Dir(Me.Tag + "\data\*.qry")
While tFileName <> ""
   tFileCount = tFileCount + 1
   tFileName = Dir
Wend
If tFileCount < 1 Then
   MsgBox "您选中的目录中没有查询文件，请重新选择", vbExclamation, XTTS
   GoTo Err
End If

RemoveFile App.Path + "\DiskDB.mdb"
FileCopy App.Path + "\diskdbmodule.mdb", App.Path + "\DiskDB.mdb"


'连接数据库
Call CntDiskDB(App.Path + "\diskdb.mdb")

'创建表结构
If MakeDiskDbStructure = False Then GoTo Err
If ImportFixedTableData = False Then GoTo Err

'修改rooot表
gAccessDbs.Execute "delete from root_table"
gAccessDbs.Execute "insert into root_table (root_id,root_type,root_path,root_status,root_name,access_type,is_root,volume_label) values(" & _
          "" + "1" + "," & _
          "" + "6" + "," & _
          "'" + "Z:" + "'," & _
          "" + "0" + "," & _
          "'" + TxtRootName + "'," & _
          "" + "0" + "," & _
          "" + "0" + ",'" + TxtVolumeLabel + "')"
          
'拷贝业务数据
i = 0
tFileName = Dir(Me.Tag + "\data\*.qry")
While tFileName <> ""
   PBar(3).Value = i / tFileCount * 100
   Label2(3).Caption = "进度：" + Format(i / tFileCount, "0%")
   DoEvents
   If ImportToAccess(Me.Tag + "\data\" + tFileName) = False Then GoTo Err
   tFileName = Dir
   i = i + 1
Wend
Label2(3).Caption = "完成"
PBar(3).Value = 100

'拷贝电子文件
i = 0
'tFileName = Dir(Me.Tag + "\data\*.qry")

Set fd = fs.GetFolder(Me.Tag + "\data")
gDiskSize = fd.Size
For Each tfile In fd.Files
   PBar(5).Value = i / fd.Files.Count * 100
   Label2(5).Caption = "进度：" + Format(i / fd.Files.Count, "0%")
   DoEvents
   If LCase(Right(tfile.Name, 3)) = "qry" Then
      If MoveDir(Me.Tag + "\data\" + tfile.Name) = False Then GoTo Err
   End If
   i = i + 1

Next

Label2(5).Caption = "完成"
PBar(5).Value = 100
DoEvents

Set fd = fs.GetFolder(Me.Tag)
If fd.Size > gDiskCapacity Then
   MsgBox "当前整理的目录容量已经超过可刻盘最高限制", vbExclamation, XTTS
   GoTo Err
End If

If Not gAccessDbs Is Nothing Then gAccessDbs.Close
If Not gOrclDbs Is Nothing Then gOrclDbs.Close
If Not gWrks Is Nothing Then gWrks.Close

FileCopy App.Path + "\DiskDB.mdb", Me.Tag + "\data\DiskDB.mdb"

MsgBox "光盘已经成功整理完毕", vbExclamation, XTTS

Call SaveEventLog("6099", 0, "", "", "刻盘整理" + fd.Name)

Me.Enabled = True

Exit Sub
Err:
   MsgBox Err.Description
   Me.Enabled = True
   If Not gAccessDbs Is Nothing Then gAccessDbs.Close
   If Not gOrclDbs Is Nothing Then gOrclDbs.Close
   If Not gWrks Is Nothing Then gWrks.Close
End Sub

Private Sub Form_Load()
Dim i As Integer
For i = 0 To 2
  PBar(i).Value = 0
Next i
CheckAll.Value = 0
End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error GoTo Err
If Not gAccessDbs Is Nothing Then gAccessDbs.Close
If Not gOrclDbs Is Nothing Then gOrclDbs.Close
If Not gWrks Is Nothing Then gWrks.Close

Err:
End Sub


Private Sub Timer1_Timer()
   Picture3.Left = Picture3.Left + 50
   If Picture3.Left > Picture2.Left + Picture2.Width Then
      Picture3.Left = Picture2.Left - Picture3.Width
   End If
End Sub

'#####################################################################################
'创建数据库结构
'#####################################################################################
Public Function MakeDiskDbStructure() As Boolean
On Error GoTo Err
'建立连接
Dim i As Integer
Dim tStr As String
Dim tRdoTable As rdoTable
Dim tRdoColumn As rdoColumn
Dim CreateStr As String
Dim tDAOTdf As TableDef
Dim tRdoRes As rdoResultset
Dim tRdoRes2 As rdoResultset

i = 1
gWrks.BeginTrans

For Each tRdoTable In GblRdoCon.rdoTables
    PBar(0).Value = i / GblRdoCon.rdoTables.Count * 100
    Label2(0).Caption = Format(i / GblRdoCon.rdoTables.Count, "0%")

    Set tRdoRes = GblRdoCon.OpenResultset("select * from Dict_Table where is_backup=1 and upper(table_name)='" + UCase(tRdoTable.Name) + "'", rdOpenDynamic, rdConcurRowVer)
    
    If Not tRdoRes.EOF Or InStr(1, UCase(tRdoTable.Name), "FILE_") = 1 Or InStr(1, UCase(tRdoTable.Name), "VOLUME_") = 1 Then
       
       Set tRdoRes2 = GblRdoCon.OpenResultset("select * from " + tRdoTable.Name, rdOpenDynamic, rdConcurRowVer)
       For Each tRdoColumn In tRdoRes2.rdoColumns
           Call GetCreateStr(tRdoColumn, tStr)
           CreateStr = CreateStr + tStr
       Next
       CreateStr = "create table " + tRdoTable.Name + "(" + RemoveString(CreateStr, ",", 2) + ");"
       gAccessDbs.Execute CreateStr
    End If
    DoEvents
    CreateStr = ""
    i = i + 1
Next
'For Each tRdoTable In GblRdoCon.rdoTables
'    PBar(0).Value = i / GblRdoCon.rdoTables.Count * 100
'    Label2(0).Caption = Format(i / GblRdoCon.rdoTables.Count, "0%")
'    DoEvents
'    '是否是系统表
'    Set GblRdoRes = GblRdoCon.OpenResultset("select * from tab where upper(Tname) ='" + UCase(tRdoTable.Name) + "'", rdOpenDynamic, rdConcurRowVer)
'    If Not (GblRdoRes.EOF) Then
'       If UCase(Mid(tRdoTable.Name, 1, 2)) <> "SM" And UCase(Mid(tRdoTable.Name, 1, 3)) <> "EVT" And UCase(tRdoTable.Name) <> "PROPERTYBEANTBL" Then
'          tStr = tRdoTable.Name
'          For Each tRdoColumn In tRdoTable.rdoColumns
'              tStr = tRdoTable.Name
'              Call GetCreateStr(tRdoColumn, tStr)
'              CreateStr = CreateStr + tStr
'          Next
'          CreateStr = "create table " + tRdoTable.Name + "(" + RemoveString(CreateStr, ",", 2) + ");"
'          gAccessDbs.Execute CreateStr
'
'          DoEvents
'          'Call CreateIndex(tRdoTable.Name)
'          CreateStr = ""
'       End If
'    End If
'    i = i + 1
'Next
gWrks.CommitTrans
Label2(0).Caption = "完成"
PBar(0).Value = 100

'创建索引
i = 1
For Each tDAOTdf In gAccessDbs.TableDefs
    PBar(7).Value = i / gAccessDbs.TableDefs.Count * 100
    Label2(7).Caption = Format(i / gAccessDbs.TableDefs.Count, "0%")
    DoEvents
    Call CreateIndex(tDAOTdf.Name)
    i = i + 1
Next
Label2(7).Caption = "完成"
PBar(7).Value = 100

MakeDiskDbStructure = True
Exit Function
Err:
   gWrks.Rollback
   MakeDiskDbStructure = False
End Function

'#####################################################################################
'导固定表数据
'#####################################################################################
Public Function ImportFixedTableData() As Boolean
On Error GoTo Err
Dim tRdoTable As rdoTable
Dim i As Integer
Dim tRdoRes As rdoResultset

gWrks.BeginTrans

Set tRdoRes = GblRdoCon.OpenResultset("select * from Dict_Table where is_backup=1", rdOpenDynamic, rdConcurRowVer)
While Not tRdoRes.EOF
    PBar(1).Value = i / tRdoRes.RowCount * 100
    Label2(1).Caption = Format(i / tRdoRes.RowCount, "0%")
    DoEvents
    If ImportData("select * from " + tRdoRes.rdoColumns("table_name"), tRdoRes.rdoColumns("table_name"), PBar(2)) = False Then GoTo Err
    i = i + 1
    tRdoRes.MoveNext
Wend

gWrks.CommitTrans
Label2(1).Caption = "完成"
PBar(1).Value = 100
ImportFixedTableData = True
Exit Function
Err:
gWrks.Rollback
ImportFixedTableData = False
End Function

'#####################################################################################
'创建表结构字串 pRdoColumn为oracle表中的一个字段 rStr为返回的创建该字段的sql语句（对access表）
'#####################################################################################
Public Function GetCreateStr(pRdoColumn As rdoColumn, rStr As String) As Boolean
On Error GoTo Err
Dim tStr As String
If pRdoColumn Is Nothing Then GoTo Err
With pRdoColumn
  rStr = .Name
  Select Case .Type
    Case 1 'rdTypeCHAR 1 是固定长度的字符串。长度由 Size 属性设置。
       If .Size < 255 Then
          rStr = rStr + " char(" + CStr(.Size) + ")"
       Else
          rStr = rStr + " memo"
       End If
    Case 3 'rdTypeDECIMAL 3 带符号的、精确的、带有精度为 p 及比例为 s 的数字值（1 ≤ p ≤15，0 ≤ s ≤ p）。
       rStr = rStr + " int"
    
    Case 9 'rdTypeDATE 9 Date－依赖于数据源。
       rStr = rStr + " date"
    
    Case 11 'rdTypeTIMESTAMP 11 时间标记－依赖于数据源。
       rStr = rStr + " date"
    
    Case 12 'rdTypeVARCHAR 12 可变长字符串。最大长度为 255。
       If .Size < 255 Then
          rStr = rStr + " char(" + CStr(.Size) + ")"
       Else
          rStr = rStr + " memo"
       End If
    
    Case Else
       rStr = rStr + " memo"
       MsgBox "没有数据类型" + CStr(.Type) + " name:" + .Name
       
'    Case 2 'rdTypeNUMERIC 2 带符号的、精确的、带有精度为 p 及比例为 s 的数字值（1 ≤ p ≤15，0 ≤ s ≤ p）。
'       MsgBox "没有数据类型" + CStr(.Type) + " name:" + .Name
'
'
'    Case 4 'rdTypeINTEGER 4 带符号的、精确的、带有精度为 10 及比例为 0 的数字值（带符号： -231 ≤ n ≤ 231-1，无符号：0 ≤ n ≤ 232-1）。
'       MsgBox "没有数据类型" + CStr(.Type) + " name:" + .Name
'
'    Case 5 'rdTypeSMALLINT 5 带符号的、精确的、带有精度为 5 及比例为 0 的数字值（带符号： -32,768 ≤ n ≤ 32,767，无符号：0 ≤ n ≤ 65,535）。
'       MsgBox "没有数据类型" + CStr(.Type) + " name:" + .Name
'
'    Case 6 'rdTypeFLOAT 6 带符号的、带有尾数精度为 15 的近似数字值（零或绝对值为 10-308 到 10308）。
'       MsgBox "没有数据类型" + CStr(.Type) + " name:" + .Name
'
'    Case 7 'rdTypeREAL 7 带符号的、带有尾数精度为 7 的近似数字值（零或绝对值为 10-38 到 1038）。
'       MsgBox "没有数据类型" + CStr(.Type) + " name:" + .Name
'
'    Case 8 'rdTypeDOUBLE 8 带符号的、带有尾数精度为 15 的近似数字值（零或绝对值为 10-308 到 10308）。
'       MsgBox "没有数据类型" + CStr(.Type) + " name:" + .Name
'
'    Case 10 'rdTypeTIME 10 Time－依赖于数据源。
'       MsgBox "没有数据类型" + CStr(.Type) + " name:" + .Name
'    Case -1 'rdTypeLONGVARCHAR -1 可变长字符串。最大长度由数据源确定。
'       MsgBox "没有数据类型" + CStr(.Type) + " name:" + .Name
'    Case -2 'rdTypeBINARY -2 固定长度的二进制数据。最大长度为 255。