📄 frmtreedef.frm
字号:
TabIndex = 40
Top = 480
Width = 5295
_ExtentX = 9340
_ExtentY = 5953
_Version = 393217
HideSelection = 0 'False
Indentation = 529
LabelEdit = 1
Style = 7
ImageList = "ImgTree"
Appearance = 1
End
Begin MSComctlLib.ListView LVViewField
Height = 1935
Left = 240
TabIndex = 48
Top = 840
Width = 4215
_ExtentX = 7435
_ExtentY = 3413
View = 3
LabelEdit = 1
LabelWrap = -1 'True
HideSelection = 0 'False
Checkboxes = -1 'True
FullRowSelect = -1 'True
_Version = 393217
Icons = "LVBigImg"
SmallIcons = "LVSmallImg"
ColHdrIcons = "LVColImg"
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
NumItems = 1
BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
Text = "显示字段"
Object.Width = 2540
EndProperty
End
Begin MSComctlLib.ListView LVResult
Height = 855
Left = 240
TabIndex = 49
Top = 3000
Width = 5295
_ExtentX = 9340
_ExtentY = 1508
View = 3
LabelWrap = -1 'True
HideSelection = -1 'True
AllowReorder = -1 'True
FullRowSelect = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
NumItems = 0
End
End
Begin VB.Timer Timer1
Interval = 50
Left = 0
Top = 0
End
Begin VB.PictureBox Picture2
BorderStyle = 0 'None
Height = 135
Left = 0
Picture = "FrmTreeDef.frx":01ED
ScaleHeight = 135
ScaleWidth = 9015
TabIndex = 13
Top = 600
Width = 9015
Begin VB.PictureBox Picture3
BorderStyle = 0 'None
Height = 135
Left = 3840
Picture = "FrmTreeDef.frx":1A53
ScaleHeight = 135
ScaleWidth = 5055
TabIndex = 14
Top = 0
Width = 5055
End
End
Begin VB.CommandButton CmdCancel
Caption = "返回(&R)"
Height = 375
Left = 4920
TabIndex = 1
Top = 5040
Width = 855
End
Begin VB.CommandButton CmdOK
Caption = "添加(&I)"
Height = 375
Left = 3960
TabIndex = 0
Top = 5040
Width = 855
End
Begin MSComctlLib.ImageList ImgTree
Left = -120
Top = 2400
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 2
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "FrmTreeDef.frx":327D
Key = "Main"
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "FrmTreeDef.frx":36CF
Key = "Selected"
EndProperty
EndProperty
End
Begin VB.PictureBox Picture1
BorderStyle = 0 'None
Height = 615
Left = 0
Picture = "FrmTreeDef.frx":3B21
ScaleHeight = 615
ScaleWidth = 8895
TabIndex = 15
Top = 0
Width = 8895
End
Begin VB.CommandButton CmdApply
Caption = "应用(&A)"
Height = 375
Left = 4920
TabIndex = 46
Top = 5040
Visible = 0 'False
Width = 855
End
Begin VB.Menu p_Mnu
Caption = "p_Mnu"
Visible = 0 'False
Begin VB.Menu m_Insert
Caption = "增加节点"
Begin VB.Menu m_Insert_Do
Caption = "插入"
Index = 0
End
Begin VB.Menu m_Insert_Do
Caption = "追加"
Index = 1
End
Begin VB.Menu m_Insert_Do
Caption = "子节点"
Index = 2
End
End
Begin VB.Menu m_Modify
Caption = "修改节点"
End
Begin VB.Menu m_Delete
Caption = "删除节点"
End
Begin VB.Menu s
Caption = "-"
End
Begin VB.Menu m_List
Caption = "定义列表"
End
Begin VB.Menu m_Refresh
Caption = "刷新"
End
End
End
Attribute VB_Name = "FrmTreeDef"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit '错误代码从3001开始编制
Public gOperate_Type As Integer '操作类型
Dim gQueryField() As String '全局查询字段3维数组，1维对应CbxFieldName中的选项2维对应数据类型3维对应该字段的数据字典
Private Sub CbxDictType_Change()
TxtFieldCnName = CbxDictType.Text
End Sub
Private Sub CbxDictType_Click()
TxtFieldCnName = CbxDictType.Text
End Sub
Private Sub CbxFieldEnName_Change()
TxtFieldCnName = CbxFieldEnName.Text
End Sub
Private Sub CbxFieldEnName_Click()
TxtFieldCnName = CbxFieldEnName.Text
End Sub
Private Sub CbxViewList_Change()
'FrameList.Enabled = True
Select Case CbxViewList.ListIndex
Case 0
OptListType(0).Enabled = False
OptListType(1).Enabled = False
OptListType(0).Value = False
OptListType(1).Value = False
TabMain.TabEnabled(2) = False
Case 1 'all
OptListType(0).Enabled = True
OptListType(1).Enabled = True
OptListType(0).Value = True
TabMain.TabEnabled(2) = True
Case 2 'file
OptListType(0).Enabled = False
OptListType(1).Enabled = True
OptListType(1).Value = True
TabMain.TabEnabled(2) = True
Case 3 'volume
OptListType(0).Enabled = True
OptListType(1).Enabled = False
OptListType(0).Value = True
TabMain.TabEnabled(2) = True
End Select
End Sub
Private Sub CbxViewList_Click()
Call CbxViewList_Change
End Sub
Private Sub CmdApply_Click()
On Error GoTo Err
gWrks.CommitTrans
gWrks.BeginTrans
Err:
End Sub
Private Sub CmdCancel_Click()
On Error GoTo Err
'If MsgBox("您是否要取消刚才做的所有操作", vbQuestion + vbYesNo, XTTS) = vbNo Then Exit Sub
'gWrks.Rollback
Unload Me
Err:
End Sub
Private Sub CmdList_Click()
Dim tTypeCode As String
Dim i As Integer
Dim tStr As String
Dim tFieldName As String
On Error GoTo Err
If Trim(TxtTableName) = "" Then
MsgBox "请先输入表名", vbExclamation, XTTS
TabMain.Tab = 1
TxtTableName.SetFocus
Exit Sub
End If
If InStr(1, UCase(TxtTableName), "FILE") <> 0 Then
If InStr(1, TxtTableName, "_") <> 0 Then
tTypeCode = UCase(Mid(TxtTableName, InStr(1, TxtTableName, "_") + 1))
End If
ElseIf InStr(1, UCase(TxtTableName), "VOLUME") <> 0 Then
If InStr(1, TxtTableName, "_") <> 0 Then
tTypeCode = UCase(Mid(TxtTableName, InStr(1, TxtTableName, "_") + 1))
End If
End If
If CbxViewList.ItemData(CbxViewList.ListIndex) = 1 Then '案卷文件
If Not (HasObject(tTypeCode, 1) = True And (HasObject(tTypeCode, 2) = True Or HasObject(tTypeCode, 3) = True)) Then
MsgBox "当前所选列表类型不正确，请重新选择", vbExclamation, XTTS
TabMain.Tab = 1
CbxViewList.SetFocus
Exit Sub
End If
ElseIf CbxViewList.ItemData(CbxViewList.ListIndex) = 2 Then '文件
If Not HasObject(tTypeCode, 1) = True Then
MsgBox "当前所选列表类型不正确，请重新选择", vbExclamation, XTTS
TabMain.Tab = 1
CbxViewList.SetFocus
Exit Sub
End If
ElseIf CbxViewList.ItemData(CbxViewList.ListIndex) = 3 Then '案卷
If Not (HasObject(tTypeCode, 2) = True Or HasObject(tTypeCode, 3) = True) Then
MsgBox "当前所选列表类型不正确，请重新选择", vbExclamation, XTTS
TabMain.Tab = 1
CbxViewList.SetFocus
Exit Sub
End If
End If
If CbxViewList.ListIndex = 2 Then '仅文件
tStr = "2"
Else
tStr = "1"
End If
DoEvents
LVResult.ColumnHeaders.Clear
'LVViewField.Visible = False
For i = 1 To LVViewField.ListItems.Count
tFieldName = ""
Call GetValue(tFieldName, "field_name", LVViewField.ListItems(i).key)
Set gRst = gDbs.OpenRecordset("select * from list_defination where node_id=" + TxtNodeID + " and list_type=" + tStr + " and FIELD_EN_NAME='" + tFieldName + "' order by view_index")
If gRst.EOF Then
LVViewField.ListItems(i).Checked = False
Else
LVViewField.ListItems(i).Checked = True
LVResult.ColumnHeaders.Add , LVViewField.ListItems(i).key, LVViewField.ListItems(i).Text
End If
Next i
CmdOK.Visible = True
TabMain.Tab = 2
Err:
'LVViewField.Visible = True
Me.MousePointer = 0
End Sub
Private Sub CmdOK_Click()
On Error GoTo Err
Dim tNodeType As String
Dim t_Dict_Type As String
Dim tFieldName As String
Dim i As Integer
Dim tStr As String
Dim tNodeID As String
gErrDescription = ""
If CmdOK.Caption = "添加(&I)" Then
If TabMain.Tab = 1 Then '添加节点
If OptNodeType(0).Value = True Then
tNodeType = "0"
ElseIf OptNodeType(1).Value = True Then
tNodeType = "1"
ElseIf OptNodeType(2).Value = True Then
tNodeType = "2"
End If
gDbs.Execute "update tree_defination set node_level_index=node_level_index+1 " & _
"where tree_type=" + TxtTreeType + " and parent_node_id=" & _
TxtParentNodeID + " and node_level_index>=" + TxtLevelIndex
Set gRst = gDbs.OpenRecordset("select max(node_id) as a from TREE_DEFINATION ")
If gRst.EOF Then
tNodeID = "1"
Else
tNodeID = CStr(gRst.Fields("a") + 1)
End If
gDbs.Execute "insert into tree_defination " & _
"(node_id,tree_type,tree_name,tree_user_name," & _
"parent_node_id,node_level_index,field_en_name," & _
"field_cn_name,is_root,field_value," & _
"table_name,type_code,node_type,view_list," & _
"where_string,data_type,system_dict_type) values(" & _
tNodeID + "," + TxtTreeType + ",'" + TxtTreeName + "','" & _
TxtUserName + "'," + TxtParentNodeID + "," + TxtLevelIndex + ",'" & _
CbxFieldEnName.Text + "','" + TxtFieldCnName + "',0,'" & _
TxtFieldValue + "','" + TxtTableName + "','" & _
TxtTypeCode + "'," + tNodeType + "," + CStr(CbxViewList.ListIndex) & _
",'" + Replace(TxtWhereString, "'", gReplaceChar) + "',0," + CStr(CbxDictType.ItemData(CbxDictType.ListIndex)) + ")"
Call SaveEventLog("6099", 0, "", "", "增加自定义节点:" + TxtTreeType + " " + TxtTreeName + " " + TxtParentNodeID)
MsgBox "节点添加成功", vbExclamation, XTTS
Call ViewTreeRoot(CInt(TxtTreeType), "")
'TabMain.Tab = 0
ElseIf TabMain.Tab = 2 Then '添加列表
If OptListType(0).Value = True Then '案卷
tStr = "0"
Else
If CbxViewList.ListIndex = 2 Then '仅文件
tStr = "2"
Else
tStr = "1"
End If
End If
gDbs.Execute "delete from list_defination where node_id=" + TxtNodeID + " and list_type=" + tStr
gDbs.Execute "update tree_defination set view_list=" + CStr(CbxViewList.ListIndex) + " where node_id=" + TxtNodeID
For i = 1 To LVResult.ColumnHeaders.Count
Call GetValue(tFieldName, "field_name", LVResult.ColumnHeaders(i).key)
Call GetValue(t_Dict_Type, "dict_type", LVResult.ColumnHeaders(i).key)
'tSql = tSql + tFieldName + " as " + Trim(LVResult.ColumnHeaders(i).Text) + ","
gDbs.Execute "insert into list_defination (node_id,field_en_name,field_cn_name,view_index,system_dict_type,order_by,type_code,list_type,data_type) " & _
"values(" + TxtNodeID + ",'" + tFieldName + "','" + Trim(LVResult.ColumnHeaders(i).Text) + "'," + CStr(i) + "," + t_Dict_Type + ",'','" + TxtTypeCode + "'," + tStr + ",0)"
Next i
MsgBox "列表添加成功", vbExclamation, XTTS
End If
ElseIf CmdOK.Caption = "修改(&M)" Then
If TabMain.Tab = 1 Then '修改节点
gDbs.Execute "update tree_defination set field_cn_name='" + TxtFieldCnName + "',where_string='" + Replace(TxtWhereString, "'", gReplaceChar) + "' where node_id=" + TxtNodeID
MsgBox "节点修改成功", vbExclamation, XTTS
Call ViewTreeRoot(CInt(TxtTreeType), "")
Call SaveEventLog("6099", 0, "", "", "修改自定义节点:" + TxtNodeID)
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -