📄 frmcreatenewdir.frm
字号:
VERSION 5.00
Begin VB.Form FrmCreateNewDir
BorderStyle = 1 'Fixed Single
Caption = "创建新目录"
ClientHeight = 3525
ClientLeft = 45
ClientTop = 330
ClientWidth = 4575
Icon = "FrmCreateNewDir.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3525
ScaleWidth = 4575
StartUpPosition = 2 'CenterScreen
Begin VB.CommandButton CmdCancel
Caption = "返回(&R)"
Height = 375
Left = 2880
TabIndex = 11
Top = 3000
Width = 855
End
Begin VB.CommandButton CmdOK
Caption = "确定(&O)"
Height = 375
Left = 840
TabIndex = 10
Top = 3000
Width = 855
End
Begin VB.Frame Frame1
Height = 125
Left = 0
TabIndex = 9
Top = 2640
Width = 4605
End
Begin VB.ComboBox CbxType
BeginProperty Font
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
ItemData = "FrmCreateNewDir.frx":014A
Left = 1680
List = "FrmCreateNewDir.frx":0160
Style = 2 'Dropdown List
TabIndex = 8
Top = 2160
Width = 2295
End
Begin VB.TextBox TxtVolumeLabel
Height = 360
Left = 1680
TabIndex = 6
Top = 960
Width = 2295
End
Begin VB.TextBox TxtName
Height = 360
Left = 1680
TabIndex = 0
Top = 1560
Width = 2295
End
Begin VB.PictureBox Picture2
BorderStyle = 0 'None
Height = 135
Left = 0
Picture = "FrmCreateNewDir.frx":019E
ScaleHeight = 135
ScaleWidth = 7455
TabIndex = 2
Top = 600
Width = 7455
Begin VB.PictureBox Picture3
BorderStyle = 0 'None
Height = 135
Left = 1920
Picture = "FrmCreateNewDir.frx":1A04
ScaleHeight = 135
ScaleWidth = 5655
TabIndex = 3
Top = 0
Width = 5655
End
End
Begin VB.PictureBox Picture1
BorderStyle = 0 'None
Height = 615
Left = 0
Picture = "FrmCreateNewDir.frx":322E
ScaleHeight = 615
ScaleWidth = 4935
TabIndex = 1
Top = 0
Width = 4935
Begin VB.Timer Timer1
Interval = 50
Left = 0
Top = 0
End
End
Begin VB.Label Label3
Caption = "类型"
Height = 255
Left = 600
TabIndex = 7
Top = 2280
Width = 735
End
Begin VB.Label Label2
Caption = "描述"
Height = 255
Left = 600
TabIndex = 5
Top = 1680
Width = 615
End
Begin VB.Label Label1
Caption = "名称"
Height = 255
Left = 600
TabIndex = 4
Top = 1080
Width = 735
End
End
Attribute VB_Name = "FrmCreateNewDir"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public gParentRootID As String
Private Sub CmdCancel_Click()
Unload Me
End Sub
Private Sub CmdOK_Click()
Dim tStr As String
Dim tPath As String
Dim tRootPath As String
Dim CheckRoot As Boolean
Dim tCDPath As String '光盘柜路径
Dim tCDID As Integer
On Error GoTo Err
If Me.Caption = "指定新目录" Then '建立根目录
tStr = "指定"
Else
tStr = "创建"
End If
If TxtName = "" Then
MsgBox "新" + tStr + "目录的描述不能为空,请重新输入", vbExclamation, XTTS
TxtName.SetFocus
Exit Sub
End If
If TxtVolumeLabel = "" Then
MsgBox "新增目录的" + Label1.Caption + "不能为空,请重新输入", vbExclamation, XTTS
'TxtVolumeLabel.SetFocus
Exit Sub
End If
If Me.Caption = "指定新目录" Then
tPath = TxtVolumeLabel
Else '根路径+卷标
tPath = RemoveString(TxtVolumeLabel.Tag, "\", 2) + "\" + TxtVolumeLabel
End If
tPath = RemoveString(tPath, "\", 2)
If DirectoryAvailable(tPath) = False Then
Set GblRdoRes = GblRdoCon.OpenResultset("select * from root_table where root_type=" + CStr(CbxType.ItemData(CbxType.ListIndex)) + " and upper(ROOT_name) = '" + UCase(TxtName) + "'", rdOpenDynamic, rdConcurRowVer)
If Not (GblRdoRes.EOF) Then
MsgBox "您输入的" + Label2.Caption + "已存在,请重新输入", vbExclamation, XTTS
TxtName.SetFocus
Exit Sub
End If
If MsgBox("您" + tStr + "的新目录不存在，是否继续", vbQuestion + vbYesNo, XTTS) = vbNo Then
Exit Sub
End If
'Else
If CbxType.ItemData(CbxType.ListIndex) <> 5 Then
If CreateNewDir(tPath) = False Then
MsgBox "系统创建路径失败,请与管理员联系", vbExclamation, XTTS
Exit Sub
End If
End If
'End If
Else
MsgBox "您指定的目录已存在", vbExclamation, XTTS
Exit Sub
End If
Set GblRdoRes = GblRdoCon.OpenResultset("select * from root_table where root_type=" + CStr(CbxType.ItemData(CbxType.ListIndex)) + " and upper(ROOT_PATH) LIKE '%" + UCase(tPath) + "' and (is_root=1 or (is_root=0 and access_type=1))", rdOpenDynamic, rdConcurRowVer)
If Not (GblRdoRes.EOF) Then
MsgBox "您输入的" + Label1.Caption + "已存在,请重新输入", vbExclamation, XTTS
TxtVolumeLabel.SetFocus
Exit Sub
End If
GblRdoCon.BeginTrans
If Me.Caption = "指定新目录" Then '添加根路径
GblRdoCon.Execute "update root_table set root_status=2 where root_type=" + CStr(CbxType.ItemData(CbxType.ListIndex)) + " and is_root=1 and root_status=0"
GblRdoCon.Execute "insert into root_table (root_id,root_type,root_path,root_status,root_name,access_type,is_root,parent_root_id) values(" & _
"seq_root.nextval," + CStr(CbxType.ItemData(CbxType.ListIndex)) + ",'" + tPath + "',0,'" + TxtName + "',1,1,0)"
Else '添加普通路径
GblRdoCon.Execute "insert into root_table (root_id,root_type,root_path,root_status,root_name,access_type,is_root,parent_root_id,volume_label) values(" & _
"seq_root.nextval," + CStr(CbxType.ItemData(CbxType.ListIndex)) + ",'" + tPath + "',0,'" + TxtName + "',1,0," + gParentRootID + ",'" + TxtVolumeLabel + "')"
End If
GblRdoCon.CommitTrans
MsgBox tStr + "成功", vbExclamation, XTTS
Call SaveEventLog("6099", 0, "", "", Me.Caption + TxtName)
'Call FrmMain.TVRefresh("root$$" + CStr(CbxType.ItemData(CbxType.ListIndex)))
Call FrmMain.TVMain_NodeClick(FrmMain.TVMain.SelectedItem)
Exit Sub
Err:
MsgBox tStr + "失败，请与管理员联系", vbExclamation, XTTS
End Sub
Private Sub Form_Activate()
TxtName.SetFocus
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
Private Sub TxtName_KeyDown(KeyCode As Integer, Shift As Integer)
'If KeyCode = 13 Then
' TxtVolumeLabel.SetFocus
'End If
End Sub
Private Sub TxtVolumeLabel_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then
CmdOK.SetFocus
End If
End Sub
'##################################################################################################
'pOpeType 0指定新目录 1创建新目录
'##################################################################################################
Public Sub FrmInit(pOpeType As Integer, pType As Integer, pRootPath As String)
On Error GoTo Err
Dim i As Integer
Dim tIndex As Integer
CbxType.Clear
If pOpeType = 0 Then
CbxType.AddItem "临时目录"
CbxType.ItemData(CbxType.ListCount - 1) = 0
CbxType.AddItem "已建索引"
CbxType.ItemData(CbxType.ListCount - 1) = 1
CbxType.AddItem "备份目录"
CbxType.ItemData(CbxType.ListCount - 1) = 2
CbxType.AddItem "编研目录"
CbxType.ItemData(CbxType.ListCount - 1) = 3
CbxType.AddItem "增补目录"
CbxType.ItemData(CbxType.ListCount - 1) = 4
CbxType.AddItem "光盘柜"
CbxType.ItemData(CbxType.ListCount - 1) = 5
Me.Caption = "指定新目录"
Label1.Caption = "路径"
Else
CbxType.AddItem "备份目录"
CbxType.ItemData(CbxType.ListCount - 1) = 2
CbxType.AddItem "编研目录"
CbxType.ItemData(CbxType.ListCount - 1) = 3
CbxType.AddItem "增补目录"
CbxType.ItemData(CbxType.ListCount - 1) = 4
Label1.Caption = "卷标"
Me.Caption = "创建新目录"
TxtVolumeLabel = FrmVolumeLabel.GetVolumeLabel
TxtVolumeLabel.Enabled = False
If DirectoryAvailable(pRootPath) = False Then
MsgBox "当前目录不可用,请重新选定", vbExclamation, XTTS
Exit Sub
End If
Set GblRdoRes = GblRdoCon.OpenResultset("select * from root_table where root_type=" + CStr(pType) + " and upper(ROOT_PATH) LIKE '%" + UCase(pRootPath) + "'", rdOpenDynamic, rdConcurRowVer)
If GblRdoRes.EOF Then
MsgBox "您选定的根路径不可用，请重新选定", vbExclamation, XTTS
Exit Sub
End If
gParentRootID = ConvertNull(GblRdoRes.rdoColumns("root_id"))
End If
tIndex = -1
TxtVolumeLabel.Tag = pRootPath
For i = 0 To CbxType.ListCount - 1
If CbxType.ItemData(i) = pType Then
tIndex = i
Exit For
End If
Next i
CbxType.ListIndex = tIndex
FrmCreateNewDir.Show 1
Exit Sub
Err:
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -