frmmain.frm

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

'验证权限
'call GetFileRights(CInt(tFileID), g_User_Info.User_ID, "", tTypeCode, Date, 0, rEffectiveTime, rExpireTime, rMaxRights, rHasRight, Rtncode)
'If rMaxRights < 1 Then
'   MsgBox "对不起,您没有查询该文件的权限,请向管理员申请", vbExclamation, XTTS
'   Exit Sub
'End If

If Dir(App.Path + "\temp", vbDirectory) = "" Then
   MkDir App.Path + "\temp"
End If
FileCopy LVMain.SelectedItem.key, _
         App.Path + "\temp\" + LVMain.SelectedItem.Text

Call OpenFile(App.Path + "\temp\" + LVMain.SelectedItem.Text)

'Call Form1.frminit(LVFile.Tag + "\" + Item.Text)
SetMousePointer 0
Exit Sub
Err:
   SetMousePointer 0
   Call MsgErr("显示文件", "2004", "", False, LXGLY, Err.Description)
End Sub

Private Sub LVMain_ItemClick(ByVal Item As MSComctlLib.ListItem)
SBar.Panels(4) = "类型：" + Item.SubItems(1)
SBar.Panels(5) = "大小：" + Item.SubItems(2)
End Sub

Private Sub LVMain_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If LVMain.SelectedItem Is Nothing Then Exit Sub
If Button = 2 Then Me.PopupMenu mnu_view
  
End Sub

Private Sub mnu_about_Click()
FrmAboutMe.Show 1
End Sub

Private Sub mnu_Dir_Do_Click(Index As Integer)
On Error GoTo Err
mnu_Dir_Do(Index).Checked = Not (mnu_Dir_Do(Index).Checked)
If mnu_Dir_Do(Index).Checked = True Then
   Call TVRefresh("root$$" + CStr(Index))
Else
   TVMain.Nodes.Remove ("root$$" + CStr(Index))
End If
Err:
End Sub


Private Sub mnu_dir_pop_Click(Index As Integer)
On Error GoTo Err
Dim fs As FileSystemObject
Dim f As Folder
Dim rtn As Integer
Dim pNode As Node
Dim tType As String '根目录类型
Dim tParentRootID As String

Set fs = CreateObject("Scripting.FileSystemObject")
If TVMain.SelectedItem Is Nothing Then Exit Sub

If Check_Operate_Permission(CStr(g_User_Info.User_ID), "6017") = False Then
   MsgBox "当前操作员没有权限，系统终止", vbExclamation, XTTS
   Exit Sub
End If

Set pNode = TVMain.SelectedItem

Select Case Index
   Case 0 '新建
      If Len(pNode.key) = 7 And InStr(1, pNode.key, "root$$") <> 0 Then
         Call FrmCreateNewDir.FrmInit(0, Right(pNode.key, 1), "")
      ElseIf pNode.Tag = "root$$2" Or pNode.Tag = "root$$3" Then 'Or pNode.Tag = "root$$4" Then
         Call FrmCreateNewDir.FrmInit(1, Right(pNode.Tag, 1), pNode.key)
      End If
      
   Case 1 '删除
      
      If pNode.Parent Is Nothing Then Exit Sub
      
      If pNode.Parent.Tag = "root$$0" Then
         
         FrmDeleteTempFile.Show 1
      
      '备份盘路径
      ElseIf pNode.Parent.Tag = "root$$2" Then
      
         tType = Right(pNode.Parent.Tag, 1)
         
         Set GblRdoRes = GblRdoCon.OpenResultset("select * from root_table where is_root=0 and root_type=5 and root_name='" + pNode.Text + "'", rdOpenDynamic, rdConcurRowVer)
         If GblRdoRes.EOF Then
            MsgBox "当前目录未刻盘", vbExclamation, XTTS
            Exit Sub
         End If
         
         Set GblRdoRes = GblRdoCon.OpenResultset("select * from root_table where is_root=0 and root_type=" + tType + " and upper(root_path) like upper('%" + pNode.key + "') and root_name='" + pNode.Text + "'", rdOpenDynamic, rdConcurRowVer)
         If GblRdoRes.EOF Then
            MsgBox "当前目录不存在", vbExclamation, XTTS
            Exit Sub
         End If
         
         If GblRdoRes.rdoColumns("root_status") <> 2 Then '未刻盘
            If Dir(GblRdoRes.rdoColumns("root_path") + "\*.*") <> "" Then
               MsgBox "当前所选目录未刻盘且已有数据，不能删除", vbExclamation, XTTS
               Exit Sub
            End If
            Set f = fs.GetFolder(GblRdoRes.rdoColumns("root_path"))
            If f.SubFolders.Count > 0 Then
               MsgBox "当前所选目录未刻盘且已有数据，不能删除", vbExclamation, XTTS
               Exit Sub
            End If
         Else
         End If
         
         If MsgBox("您确定真的要删除所选目录吗", vbQuestion + vbYesNo, XTTS) = vbNo Then Exit Sub
         
         Set f = fs.GetFolder(GblRdoRes.rdoColumns("root_path"))
         f.Delete True
         GblRdoCon.Execute "delete from root_table where root_type=2 and root_id=" + CStr(GblRdoRes.rdoColumns("root_id"))
         TVMain.Nodes.Remove (pNode.Index)
      
      '编研目录
      ElseIf pNode.Parent.Tag = "root$$3" Then
         
         tType = Right(pNode.Parent.Tag, 1)
         
         Set GblRdoRes = GblRdoCon.OpenResultset("select * from root_table where is_root=0 and root_type=" + tType + " and upper(root_path) like upper('%" + pNode.key + "') and root_name='" + pNode.Text + "'", rdOpenDynamic, rdConcurRowVer)
         
         If GblRdoRes.EOF Then
            MsgBox "当前目录不存在", vbExclamation, XTTS
            Exit Sub
         End If
         
         If MsgBox("您确定真的要删除所选目录吗", vbQuestion + vbYesNo, XTTS) = vbNo Then Exit Sub
         
         Set f = fs.GetFolder(GblRdoRes.rdoColumns("root_path"))
         If Dir(GblRdoRes.rdoColumns("root_path") + "\*.*") = "" And f.SubFolders.Count < 1 Then
            f.Delete True
         Else
            DelDir GblRdoRes.rdoColumns("root_path")
         End If
         
         GblRdoCon.Execute "delete from root_table where root_type=3 and root_id=" + CStr(GblRdoRes.rdoColumns("root_id"))
         TVMain.Nodes.Remove (pNode.Index)
      
      End If
      
   Case 3 '激活
      
      If pNode.Image = "close" Then Exit Sub '已激活
      If Not (pNode.Parent Is Nothing) Then
        '是第一级路径
        If Len(pNode.Tag) = 7 And InStr(1, pNode.Tag, "root$$") <> 0 Then
           tType = Right(pNode.Tag, 1)
           Set GblRdoRes = GblRdoCon.OpenResultset("select * from root_table where is_root=1 and root_type=" + tType + " and root_status=0 and not(upper(root_path) like upper('%" + pNode.key + "'))", rdOpenDynamic, rdConcurRowVer)
           If Not GblRdoRes.EOF Then
              MsgBox "当前系统还有可用目录，请先禁用该目录", vbExclamation, XTTS
              Exit Sub
           End If
           
           Set GblRdoRes = GblRdoCon.OpenResultset("select * from root_table where root_type=" + tType + " and upper(ROOT_PATH) LIKE '%" + UCase(pNode.key) + "'", rdOpenDynamic, rdConcurRowVer)
           If GblRdoRes.EOF Then
              MsgBox "您选定的根路径不存在，请重新选定", vbExclamation, XTTS
              Exit Sub
           End If
           tParentRootID = ConvertNull(GblRdoRes.rdoColumns("root_id"))
           
           GblRdoCon.Execute "update root_table set root_status=0 where is_root=1 and root_type=" + tType + " and upper(root_path) like upper('%" + pNode.key + "')"
           GblRdoCon.Execute "update root_table set root_status=0 where is_root=0 and root_status!=1 and root_type=" + tType + " and parent_root_id=" + tParentRootID
           Call TVRefresh(pNode.Tag)
        Else 'If pNode.Parent.Tag = "root$$2" Or pNode.Parent.Tag = "root$$3" Or pNode.Parent.Tag = "root$$4" Then
           'tType = Right(pNode.Parent.Tag, 1)
           'GblRdoCon.Execute "update root_table set root_status=0 where is_root=0 and root_type=" + tType + " and upper(root_path) like upper('%" + pNode.key + "')"
           'Call TVRefresh(pNode.Parent.Tag)
           MsgBox "只有根目录才可以被激活", vbExclamation, XTTS
        End If
      End If
   Case 4 '禁用
      
      If pNode.Image = "disable" Then Exit Sub '已禁用
      If Not (pNode.Parent Is Nothing) Then
        If Len(pNode.Tag) = 7 And InStr(1, pNode.Tag, "root$$") <> 0 Then
           tType = Right(pNode.Tag, 1)
           If MsgBox("当前目录被禁用后，系统将没有可用目录" + Chr(13) + "若要继续使用，应立即激活或新建目录" + Chr(13) + "是否继续", vbQuestion + vbYesNo) = vbNo Then Exit Sub
           
           Set GblRdoRes = GblRdoCon.OpenResultset("select * from root_table where root_type=" + tType + " and upper(ROOT_PATH) LIKE '%" + UCase(pNode.key) + "'", rdOpenDynamic, rdConcurRowVer)
           If GblRdoRes.EOF Then
              MsgBox "您选定的根路径不存在，请重新选定", vbExclamation, XTTS
              Exit Sub
           End If
           tParentRootID = ConvertNull(GblRdoRes.rdoColumns("root_id"))
           
           GblRdoCon.Execute "update root_table set root_status=2 where is_root=1 and root_type=" + tType + " and upper(root_path) like upper('%" + pNode.key + "')"
           GblRdoCon.Execute "update root_table set root_status=2 where is_root=0 and root_status!=1 and root_type=" + tType + " and parent_root_id=" + tParentRootID
           Call TVRefresh(pNode.Tag)
        '????????????????????看不到
        Else 'If pNode.Parent.Tag = "root$$2" Or pNode.Parent.Tag = "root$$3" Or pNode.Parent.Tag = "root$$4" Then
           'tType = Right(pNode.Parent.Tag, 1)
           'GblRdoCon.Execute "update root_table set root_status=2 where is_root=0 and root_type=" + tType + " and upper(root_path) like upper('%" + pNode.key + "')"
           'Call TVRefresh(pNode.Parent.Tag)
           MsgBox "只有根目录才可以被禁用", vbExclamation, XTTS
        End If
      End If
   
'   Case 9 '离线
'
'      If pNode.Image = "offline" Then Exit Sub '已离线
'      tType = Right(pNode.Tag, 1)
'      If Not (pNode.Parent Is Nothing) Then
'        If Len(pNode.Parent.key) = 7 And InStr(1, pNode.Parent.key, "root$$") <> 0 Then
'        ElseIf pNode.Tag = "root$$5" Then
'           GblRdoCon.Execute "update root_table set root_status=2 where is_root=0 and root_type=" + tType + " and upper(root_path) like upper('%" + pNode.key + "')"
'        End If
'      End If
'      Call TVRefresh(pNode.Tag)
   
   Case 6 '属性
      Call FrmDirProperty.FrmInit(1, pNode.key, pNode.FullPath)
      
End Select
Err:
End Sub

Private Sub mnu_File_Do_Click(Index As Integer)
On Error GoTo Err

Dim tFileFullName As String
Dim tFileName As String
Dim tTempPos As Integer
Dim pNode As Node
Dim tType As String
Dim tStr As String
Dim tRootID As String
Dim fd As Folder
Dim tfd As Folder
Dim tfd2 As Folder
Dim tRootPath As String
Dim tRootPath2 As String
Dim tSqlStr As String
Dim tWhereStr As String
Dim tTableName As String
Dim tQueryStr As String
Dim tNewRootID As String
Dim tVolumeLabel As String
Dim tCDLibPath As String '光盘柜路径
Dim fs As FileSystemObject
Dim f As File
Dim tRootName As String
Dim tCDRootID As String

Set fs = CreateObject("Scripting.FileSystemObject")
If TVMain.SelectedItem Is Nothing Then Exit Sub

If Check_Operate_Permission(CStr(g_User_Info.User_ID), "6015") = False Then
   MsgBox "当前操作员没有权限，系统终止", vbExclamation, XTTS
   Exit Sub
End If

Set pNode = TVMain.SelectedItem

Select Case Index
  
   Case 0 'import
      
      If pNode.Parent Is Nothing Then Exit Sub
      
      '是第一级路径
      If (pNode.Parent.Tag = "root$$2" Or pNode.Parent.Tag = "root$$3") Then  'Or pNode.Tag = "root$$4" Then
         
         tType = Right(pNode.Parent.Tag, 1)
      
         Set GblRdoRes = GblRdoCon.OpenResultset("select * from root_table where is_root=0 and root_type=" + tType + " and upper(root_path) like upper('%" + pNode.key + "') and upper(root_name)='" + UCase(pNode.Text) + "'", rdOpenDynamic, rdConcurRowVer)
         
         If GblRdoRes.EOF Then
            MsgBox "当前目录不存在", vbExclamation, XTTS
            Exit Sub
         End If
         
         If GblRdoRes.rdoColumns("access_type") <> 1 Then
            MsgBox "当前选中的目录已经封盘，不能导入查询文件", vbExclamation, XTTS
            Exit Sub
         End If
         
         If GblRdoRes.rdoColumns("root_status") <> 0 Then
            MsgBox "当前选中的目录已被禁用或是已下线，不能导入查询文件", vbExclamation, XTTS
            Exit Sub
         End If
         
         If DirectoryAvailable(GblRdoRes.rdoColumns("root_path")) = False Then
            MsgBox "当前目录不可用", vbExclamation, XTTS
            Exit Sub
         End If
         
      Else
         MsgBox "当前目录不能导入查询文件", vbExclamation, XTTS
         Exit Sub
      End If
   
      CmnDlg.CancelError = False
      CmnDlg.Filter = "定制文件 (*.qry)|*.qry"
      CmnDlg.DialogTitle = "请选择定制的查询文件"
      
      CmnDlg.ShowOpen
      tFileFullName = CmnDlg.FileName
      If tFileFullName = "" Then Exit Sub
      
      tTempPos = InStr(1, tFileFullName, " ")
      
      If tTempPos = 0 And tFileFullName <> "" Then '单个文件
         Set f = fs.GetFile(tFileFullName)
         tStr = GblRdoRes.rdoColumns("root_path")
         '文件格式检验
         Call FrmLoadQueryFile.FrmInit(f.Path, False)
         If FrmLoadQueryFile.LoadQueryFile(f.Path) = False Or FrmLoadQueryFile.GetQueryStr(tQueryStr, tTableName, tWhereStr) = False Then
            MsgBox "您选择的查询文件格式不正确，请重新生成", vbExclamation, XTTS
            Exit Sub
         End If
         '检查查询语句是否正确
         Set GblRdoRes = GblRdoCon.OpenResultset(tQueryStr, rdOpenDynamic, rdConcurRowVer)
         If Dir(tStr + "\Data", vbDirectory) = "" Then
            If CreateNewDir(tStr + "\Data") = False Then
               MsgBox "创建目录失败", vbExclamation, XTTS
               Exit Sub
            End If
         End If
         FileCopy tFileFullName, tStr + "\Data\" + f.Name
         
      Else '多个文件
         MsgBox "请选则单个文件", vbExclamation, XTTS
         Exit Sub
         
      End If
      MsgBox "导入查询文件成功", vbExclamation, XTTS
      Call SaveEventLog("6099", 0, "", "", "导入查询文件成功" + f.Name)
   
   Case 1, 3, 4 '整理刻盘
      
      If Index = 1 Then
         tStr = "光盘整理"
      ElseIf Index = 3 Then
         tStr = "封盘"
      ElseIf Index = 4 Then
         tStr = "解除封盘"
      End If
      
      If pNode.Parent Is Nothing Then Exit Sub