📄 frmmain.frm

📁 管理文档的原代码,可以把扫描的文档归类,便于查询
💻 FRM
📖 第 1 页 / 共 5 页
字号:
上一页 1 2 3 45
      '是第一级路径
      If pNode.Parent.Tag = "root$$2" Or 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 upper(root_name)='" + UCase(pNode.Text) + "'", rdOpenDynamic, rdConcurRowVer)
         
         If GblRdoRes.EOF Then
            MsgBox "当前目录不存在", vbExclamation, XTTS
            Exit Sub
         End If
         
         If GblRdoRes.rdoColumns("root_status") <> 0 Then
            MsgBox "当前选中的目录已被禁用或是已下线，不能" + tStr, vbExclamation, XTTS
            Exit Sub
         End If
         
         
         If GblRdoRes.rdoColumns("access_type") <> 1 And (Index = 1 Or Index = 3) Then
            MsgBox "当前选中的目录已经封盘，不能" + tStr, vbExclamation, XTTS
            Exit Sub
         End If
         
         If DirectoryAvailable(GblRdoRes.rdoColumns("root_path")) = False Then
            MsgBox "当前目录不可用", vbExclamation, XTTS
            Exit Sub
         End If
         
      Else
         MsgBox "当前目录不能" + tStr, vbExclamation, XTTS
         Exit Sub
      End If
         
      SetMousePointer 11
      
      If Index = 1 Then '光盘整理
        FrmMakeDisk.Tag = RemoveString(GblRdoRes.rdoColumns("root_path"), "\", 2)
        FrmMakeDisk.TxtDiskType = tType
        FrmMakeDisk.TxtRootName = ConvertNull(GblRdoRes.rdoColumns("root_name"))
        FrmMakeDisk.TxtVolumeLabel = ConvertNull(GblRdoRes.rdoColumns("volume_label"))
        FrmMakeDisk.TxtRootID = CStr(GblRdoRes.rdoColumns("root_id"))
        FrmMakeDisk.Show 1
      ElseIf Index = 3 Then '封盘
        
        tRootPath = RemoveString(GblRdoRes.rdoColumns("root_path"), "\", 2)
        tRootID = CStr(GblRdoRes.rdoColumns("root_id"))
        
        If pNode.Parent.Tag = "root$$2" Then '是备份盘
           '删除硬盘已建索引目录下相应子目录
           '获取可用硬盘已建索引目录
           Set GblRdoRes = GblRdoCon.OpenResultset("select * from root_table where is_root=1 and root_type=1 and root_status=0", rdOpenDynamic, rdConcurRowVer)
           tRootPath2 = GetRootPath(CStr(GblRdoRes.rdoColumns("root_id"))) '硬盘虚拟目录
           Set fd = fs.GetFolder(tRootPath)
           For Each tfd In fd.SubFolders '当前刻盘目录下的所有子目录
               For Each tfd2 In tfd.SubFolders '所有档案文件
                   'need test
                   DelDir tRootPath2 + "\" + tfd.Name + "\" + tfd2.Name
                   'RemoveFile tRootPath2 + "\" + tfd.Name + "\" + tfd2.Name + "\*.*"
                   'RemoveDirectory tRootPath2 + "\" + tfd.Name + "\" + tfd2.Name
               Next
           Next
        End If
        
        ''拷贝setup文件
        If CopySetupFile(tRootPath) = False Then GoTo Err
        GblRdoCon.Execute "update root_table set access_type=2 where root_id=" + tRootID
        tStr = tStr + fs.GetFolder(tRootPath).Name
        Call SaveEventLog("6099", 0, "", "", tStr)
        MsgBox tStr + "成功", vbExclamation, XTTS
        
      ElseIf Index = 4 Then '解除封盘
        GblRdoCon.Execute "update root_table set access_type=1 where root_id=" + CStr(GblRdoRes.rdoColumns("root_id"))
        
        Call SaveEventLog("6099", 0, "", "", tStr + CStr(GblRdoRes.rdoColumns("root_id")))
        MsgBox tStr + "成功", vbExclamation, XTTS
        
      End If
   
   Case 5 '刻盘登记
      
      tStr = "刻盘登记"
      
      If pNode.Parent Is Nothing Then Exit Sub
      
      '是第一级路径
      If 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=" + 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("root_status") <> 0 Then
            MsgBox "当前选中的目录已被禁用或是已下线，不能" + tStr, vbExclamation, XTTS
            Exit Sub
         End If
         
         If GblRdoRes.rdoColumns("access_type") <> 2 Then
            MsgBox "当前选中的目录还没有封盘，不能" + tStr, vbExclamation, XTTS
            Exit Sub
         End If
         
         If DirectoryAvailable(GblRdoRes.rdoColumns("root_path")) = False Then
            MsgBox "当前目录不可用", vbExclamation, XTTS
            Exit Sub
         End If
         
      Else
         MsgBox "当前目录不能" + tStr, vbExclamation, XTTS
         Exit Sub
      End If
      
      SetMousePointer 11
      
      '刻盘硬盘虚拟目录
      tRootPath = RemoveString(GblRdoRes.rdoColumns("root_path"), "\", 2)
      tRootID = CStr(GblRdoRes.rdoColumns("root_id"))
      tRootName = ConvertNull(GblRdoRes.rdoColumns("root_name"))
      tVolumeLabel = ConvertNull(GblRdoRes.rdoColumns("volume_label"))
      
      'If tVolumeLabel = "" Then MsgBox "光盘卷标不能为空", vbExclamation, XTTS
      
      '获取光盘柜根路径，检验光盘是否已经刻录
      Set GblRdoRes = GblRdoCon.OpenResultset("select * from root_table where is_root=1 and root_type=5 and root_status=0", rdOpenDynamic, rdConcurRowVer)
      tCDLibPath = GetRootPath(CStr(GblRdoRes.rdoColumns("root_id")))
      tCDRootID = CStr(GblRdoRes.rdoColumns("root_id"))
      If DirectoryAvailable(tCDLibPath + "\" + tVolumeLabel + "\setup") = False Then
         MsgBox "您输入的光盘柜卷标不可用", vbExclamation, XTTS
         SetMousePointer 0
         Exit Sub
      End If
      
          '检验该光盘卷表是否已存在
          Set GblRdoRes = GblRdoCon.OpenResultset("select * from root_table where is_root=0 and root_type=5 and Volume_label='" + tVolumeLabel + "'", rdOpenDynamic, rdConcurRowVer)
          If Not GblRdoRes.EOF Then
              MsgBox "您输入的光盘卷标已经存在，请将该盘更名后重新刻录", vbExclamation, XTTS
              SetMousePointer 0
              Exit Sub
          End If
          
          '添加光盘根路径记录
          GblRdoCon.Execute "insert into root_table (root_id,root_type,root_path,root_status,root_name,access_type,is_root,volume_label,parent_root_id) values(" & _
           "seq_root.nextval,5,'" + tCDLibPath + "\" + tVolumeLabel + "',0,'" + tRootName + "',2,0,'" + tVolumeLabel + "'," + tCDRootID + ")"
          Set GblRdoRes = GblRdoCon.OpenResultset("select max(root_id) as root_id from root_table", rdOpenDynamic, rdConcurRowVer)
          tNewRootID = CStr(GblRdoRes.rdoColumns("root_id")) '光盘根路径id
          
          '将所有指向该备份盘虚拟硬盘路径的文件根路径改为指向实际光盘路径
          tFileName = Dir(tRootPath + "\data\*.qry")
          While tFileName <> ""
            Call FrmLoadQueryFile.FrmInit(tRootPath + "\" + tFileName, False)
            fs.CopyFile tRootPath + "\" + tFileName, App.Path + "\temp\" + tFileName, True
            If FrmLoadQueryFile.LoadQueryFile(App.Path + "\temp\" + tFileName) = False Then GoTo Err
            If FrmLoadQueryFile.GetQueryStr(tQueryStr, tTableName, tWhereStr) = False Then GoTo Err
            
            If InStr(1, UCase(tTableName), "FILE_") <> 0 Then
            Else
               tTableName = "FILE_" + Mid(tTableName, 8)
            End If
            GblRdoCon.Execute "update " + tTableName + " set root_id =" + tNewRootID + " where root_id=" + tRootID
            tFileName = Dir
          Wend
                    
          '修改原有硬盘虚拟路径
          GblRdoCon.Execute "update root_table set root_status=2 where root_id=" + tRootID
      
      MsgBox "请确认光盘成功刻录后，手工删除模拟硬盘刻盘目录", vbExclamation, XTTS
      
'      '删除硬盘目录
'      If MsgBox("是否自动删除模拟硬盘刻盘目录", vbQuestion + vbYesNo, XTTS) = vbYes Then
'         Call DelDir(tRootPath)
'      End If
'      GblRdoCon.Execute "delete from root_table where root_id=" + tRootID
      
      Call SaveEventLog("6099", 0, "", "", tStr + tRootID)
      
    Case 7, 8 '光盘下线,添加
      
      If pNode.Parent Is Nothing Then Exit Sub
      
      '是第一级路径
      If pNode.Parent.Tag = "root$$5" 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("root_status") = 1 And Index = 7 Then
            MsgBox "当前选中的目录已下线", vbExclamation, XTTS
            Exit Sub
         ElseIf GblRdoRes.rdoColumns("root_status") = 0 And Index = 8 Then
            MsgBox "当前添加的光盘已存在", vbExclamation, XTTS
            Exit Sub
         End If
         
         If DirectoryAvailable(GblRdoRes.rdoColumns("root_path")) = False And Index = 8 Then
            MsgBox "当前添加的光盘不可用", vbExclamation, XTTS
            Exit Sub
         End If
         
      Else
         MsgBox "当前目录不能操作", vbExclamation, XTTS
         Exit Sub
      End If
      
      If Index = 7 Then
         GblRdoCon.Execute "update root_table set root_status=1 where root_id=" + CStr(GblRdoRes.rdoColumns("root_id")) + " and root_type=5"
         MsgBox "您现在可以取出光盘了", vbExclamation, XTTS
         Call SaveEventLog("6099", 0, "", "", "光盘离线" + CStr(GblRdoRes.rdoColumns("root_id")))
         
      ElseIf Index = 8 Then
         GblRdoCon.Execute "update root_table set root_status=0 where root_id=" + CStr(GblRdoRes.rdoColumns("root_id")) + " and root_type=5"
         Call SaveEventLog("6099", 0, "", "", "添加光盘" + CStr(GblRdoRes.rdoColumns("root_id")))
      End If
End Select
SetMousePointer 0
Exit Sub
Err:
    MsgErr "目录管理", "3001", "", True, LXGLY, Err.Description
    SetMousePointer 0

End Sub

Private Sub mnu_option_do_Click(Index As Integer)
mnu_option_do(Index).Checked = Not (mnu_option_do(Index).Checked)
TVMain.Nodes.Clear
LVMain.ListItems.Clear
Call TVRefresh("")
End Sub

Private Sub mnu_pop_do_Click(Index As Integer)
If Index = 0 Then
   Call LVMain_DblClick
   Exit Sub
End If
If Index > 1 Then
   Call Mnu_View_Do_Click(Index - 2)
End If
End Sub

Private Sub mnu_sys_do_Click(Index As Integer)
If Index = 0 Then
   Me.Visible = False
   FrmLock.Show 1
ElseIf Index = 1 Then
   FrmChgPwd.Show 1
ElseIf Index = 6 Then
   Unload Me
ElseIf Index = 3 Then
   FrmDeleteTempFile.Show 1
ElseIf Index = 4 Then
   FrmCreateCD.Show 1
End If
End Sub

Public Sub Mnu_View_Do_Click(Index As Integer)
On Error GoTo Err

Dim i As Integer
If Index = 0 Then
   Call LVMain_DblClick
   Exit Sub
End If

If Index <= 5 And Index >= 2 Then
    
    LVMain.View = Index - 2
    gLVMainView = Index - 2
    Call RegSetString(HKEY_LOCAL_MACHINE, gRegSubKey + "\OPTION", "LVMainView", CStr(gLVMainView))
    For i = 2 To 5
        If i = gLVMainView + 2 Then
           mnu_view_do(i).Checked = True
           'mnu_pop_do(i + 2).Checked = True
        Else
           mnu_view_do(i).Checked = False
           'mnu_pop_do(i + 2).Checked = False
        End If
    Next
ElseIf mnu_view_do(Index).Caption = "刷 新(&R)" Then
      If TVMain.SelectedItem Is Nothing Then
         TVMain.Nodes.Clear
         LVMain.ListItems.Clear
         LV.ListItems.Clear
         Call TVRefresh("")
      Else
         ClearNode TVMain.SelectedItem.key, TVMain
         LVMain.ListItems.Clear
         LV.ListItems.Clear
         Call TVMain_NodeClick(TVMain.SelectedItem)
      End If
ElseIf mnu_view_do(Index).Caption = "属 性(&P)" Then
    If LVMain.SelectedItem Is Nothing Then Exit Sub
    Call FrmDirProperty.FrmInit(0, LVMain.SelectedItem.key, LVMain.SelectedItem.Text)
End If

Err:
End Sub


Private Sub Pic1_Resize()
On Error GoTo Err
'Text(0).Move -30, -30, Pic1.Width
'TVMain.Move 0, Text(0).Height, Pic1.Width, Pic1.Height - Text(0).Height
TVMain.Move -10, -10, Pic1.Width - 20, Pic1.Height
Err:
End Sub

Private Sub Pic2_Resize()
On Error GoTo Err
Dim i As Integer
Pic3.Move 0, 0, Pic2.Width, Cbx.Height
LVMain.Move -30, Pic3.Height, Pic2.Width, Pic2.Height - Cbx.Height
For i = 1 To LVMain.ColumnHeaders.Count
    LVMain.ColumnHeaders(i).Width = LVMain.Width / LVMain.ColumnHeaders.Count
Next i
LV.Move -30, Pic3.Height, Pic2.Width, Pic2.Height - Cbx.Height
For i = 1 To LV.ColumnHeaders.Count
    LV.ColumnHeaders(i).Width = LV.Width / LV.ColumnHeaders.Count
Next i

Err:
End Sub

Private Sub Pic3_Resize()
On Error GoTo Err
Label1.Move 0, 60
Cbx.Move Label1.Width, 0, Pic3.Width - Label1.Width - 50 - CmdClear.Width - 10
CmdClear.Move Cbx.Left + Cbx.Width - 10, 0
Err:
End Sub

'############################################################
'刷新目录树，带权限校验
'参数：p_KeyWord 关键字
'############################################################
Public Function TVRefresh(p_KeyWord As String) As Boolean
On Error GoTo Err
Dim tImg As String
Dim tSelImg
上一页 1 2 3 45
💿 文件大小 325 K
👤 上传用户 smashup
📂 所属分类 Applet
🏷️ 相关标签

#文档 #代码 #查询
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -