发信人: zrsoft()
整理人: fishy(2000-04-14 17:27:12), 站内信件
|
如果你要经常处理大量的文档，那么对这些文档的归类整理就成了一个重要的问
题，如果不能合理地取个名字，放在一个好的目录中，那么过了一段时间后，你
就很有可以找不到所需要的文件了。正是针对这种问题，本人制作了一个“文档
管理软件”，专门用以管理您大量的文档，可以人为的给他们归一个类，再给他
们取一个名字，而不管它们的实际的文件名是什么。这样，不管过了多久，以要
知道它们应该属于哪一类，就可以轻松地找到它们了。
本程序用VB编写，思路是用一个数据库来记录所有的文件的类别用实际的文件名
及存放路径。在窗体的左边是一个
TreeView控件，用它从数据库中以树型结构取出所有的类别，而在右边是一个OL
E控件，用它对左边所选中的文件进行预览，只要使用右键，就可以实现对类别的
增加和删除。程序很简单，只有一个主窗体，代码如下：
VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX
"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX
"
Begin VB.Form frmMain
Caption = "文档管理"
ClientHeight = 8595
ClientLeft = 165
ClientTop = 450
ClientWidth = 11880
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmMain.frx":0000
LinkTopic = "Form1"
ScaleHeight = 8595
ScaleWidth = 11880
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton cmdDelete
Caption = "删除(&D)"
Height = 540
Left = 1680
TabIndex = 3
Top = 5400
Visible = 0 'False
Width = 975
End
Begin VB.CommandButton cmdNew
Caption = "新建(&N)"
Height = 540
Left = 720
TabIndex = 2
Top = 5400
Visible = 0 'False
Width = 975
End
Begin MSComDlg.CommonDialog cdOpen
Left = 5760
Top = 3840
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Frame frameURL
Height = 735
Left = 3480
TabIndex = 4
Top = 7320
Width = 8295
Begin VB.CommandButton cmdModify
Caption = "修改(&M)"
Height = 375
Left = 7200
TabIndex = 5
Top = 240
Width = 975
End
Begin VB.TextBox txtURL
Height = 375
Left = 840
TabIndex = 7
Top = 240
Width = 5895
End
Begin VB.CommandButton cmdBrowse
Caption = "..."
Height = 375
Left = 6720
TabIndex = 6
Top = 240
Width = 495
End
Begin VB.Label lblURL
Caption = "文件"
Height = 300
Left = 120
TabIndex = 8
Top = 360
Width = 600
End
End
Begin ComctlLib.TreeView TVDOC
Height = 8115
Left = 0
TabIndex = 0
Top = 0
Width = 3375
_ExtentX = 5953
_ExtentY = 14314
_Version = 327682
HideSelection = 0 'False
Indentation = 0
LineStyle = 1
PathSeparator = "1"
Style = 7
BorderStyle = 1
Appearance = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.OLE oleDOC
Height = 7275
Left = 3420
TabIndex = 1
Top = 0
Width = 8415
End
Begin VB.Menu mnuPop
Caption = ""
Visible = 0 'False
Begin VB.Menu mnuNew
Caption = "新建"
End
Begin VB.Menu mnuProperty
Caption = "-"
End
Begin VB.Menu mnuDelete
Caption = "删除"
End
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private DB As Database
Private RS As Recordset
Private Num1 As Long
Private Num2 As Long
Private Num3 As Long
Private Function Trim5(l As Long) As String
Trim5 = Right("0000" & CStr(l), 5)
End Function
Private Function Trim7(s As String) As String
Trim7 = Right(s, Len(s) - 7)
End Function
Private Sub cmdBrowse_Click()
On Error GoTo Errhandle
cdOpen.ShowOpen
txtURL = cdOpen.filename
Exit Sub
Errhandle:
MsgBox "出错原因：" & Err.Description
End Sub
Private Sub cmdDelete_Click()
Select Case Left(TVDOC.SelectedItem.Key, 2)
Case "R"
MsgBox "不能将此节点删除！"
Case "C1"
If MsgBox("真的要删除吗？", vbYesNo, "") = vbYes Then
SQL = "delete * from cooldoc where root='" & TVDOC.Selecte
dItem & "'"
DB.Execute SQL
TVDOC.Nodes.Remove TVDOC.SelectedItem.Key
End If
End Select
End Sub
Private Sub cmdModify_Click()
On Error GoTo Errhandle
TVDOC.SelectedItem.Key = Left(TVDOC.SelectedItem.Key, 7) & txtURL
Dim RSTemp As Recordset
Set RSTemp = DB.OpenRecordset("select * from cooldoc where root='" & T
VDOC.SelectedItem.Parent.Parent & "' and key='" & TVDOC.SelectedItem.P
arent & "' and value='" & TVDOC.SelectedItem & "'")
If Not RSTemp.EOF() Then
RSTemp.Edit
RSTemp.Fields("URL") = txtURL
RSTemp.Update
End If
Exit Sub
Errhandle:
MsgBox "出错原因：" & Err.Description
End Sub
Private Sub cmdNew_Click()
On Error GoTo Errhandle
Dim RSTemp As Recordset
Select Case Left(TVDOC.SelectedItem.Key, 2)
Case "R"
'建立根键
Set RSTemp = DB.OpenRecordset("select count(*) from cooldoc wh
ere root='新建'")
If RSTemp.Fields(0) > 0 Then
MsgBox "已经有了一个名为“新建”的类别，请先将以前的新建改
名后再使用！"
Else
Num1 = Num1 + 1
TVDOC.Nodes.Add "R", tvwChild, "C1" & Trim5(Num1) & "新建"
, "新建"
RS.AddNew
RS(0) = "新建"
RS(1) = ""
RS(2) = ""
RS(3) = ""
RS.Update
End If
Case "C1"
'建立子键
Set RSTemp = DB.OpenRecordset("select count(*) from cooldoc wh
ere root='" & Trim7(TVDOC.SelectedItem.Key) & "' and key='新建'")
If RSTemp.Fields(0) > 0 Then
MsgBox "不能建立此项目，因为重名."
Else
Num2 = Num2 + 1
TVDOC.Nodes.Add TVDOC.SelectedItem.Key, tvwChild, "C2" & T
rim5(Num2) & "新建", "新建"
RS.AddNew
RS(0) = Trim7(TVDOC.SelectedItem.Key)
RS(1) = "新建"
RS(2) = ""
RS(3) = ""
RS.Update
End If
Case "C2"
Set RSTemp = DB.OpenRecordset("select count(*) from cooldoc wh
ere root='" & Trim7(TVDOC.SelectedItem.Parent.Key) & "' and key='" & T
rim7(TVDOC.SelectedItem.Key) & "' and value='新建'")
If RSTemp.Fields(0) > 0 Then
MsgBox "不能建立此项目，因为重名."
Else
Num3 = Num3 + 1
TVDOC.Nodes.Add TVDOC.SelectedItem.Key, tvwChild, "C3" & T
rim5(Num3) & "新建", "新建"
RS.AddNew
RS(0) = Trim7(TVDOC.SelectedItem.Parent.Key)
RS(1) = Trim7(TVDOC.SelectedItem.Key)
RS(2) = "新建"
RS(3) = ""
RS.Update
End If
'建立值
Case "C3"
MsgBox "不能在此处建立新项目！"
End Select
Exit Sub
Errhandle:
MsgBox "出错原因：" & Err.Description
End Sub
Private Sub Command1_Click()
Debug.Print Screen.Height & "--" & Screen.Width
End Sub
Private Sub Form_Load()
On Error GoTo Errhandle
Me.WindowState = 2
If Screen.Height = 7200 Then
TVDOC.Height = TVDOC.Height * 0.8
TVDOC.Width = TVDOC.Width * 0.8
oleDOC.Height = oleDOC.Height * 0.8
oleDOC.Width = oleDOC.Width * 0.8
oleDOC.Left = oleDOC.Left * 0.8
frameURL.Left = frameURL.Left * 0.8
frameURL.Top = frameURL.Top * 0.8
frameURL.Height = frameURL.Height * 0.8
frameURL.Width = frameURL.Width * 0.8
lblURL.Top = lblURL.Top * 0.8
lblURL.Left = lblURL.Left * 0.8
lblURL.Height = lblURL.Height * 0.8
lblURL.Width = lblURL.Width * 0.8
txtURL.Top = txtURL.Top * 0.8
txtURL.Left = txtURL.Left * 0.8
txtURL.Height = txtURL.Height * 0.8
txtURL.Width = txtURL.Width * 0.8
cmdModify.Top = cmdModify.Top * 0.8
cmdModify.Left = cmdModify.Left * 0.8
cmdModify.Height = cmdModify.Height * 0.8
cmdModify.Width = cmdModify.Width * 0.8
cmdBrowse.Top = cmdBrowse.Top * 0.8
cmdBrowse.Left = cmdBrowse.Left * 0.8
cmdBrowse.Height = cmdBrowse.Height * 0.8
cmdBrowse.Width = cmdBrowse.Width * 0.8
End If
If Dir(App.Path & "\CoolDOC.mdb") = "" Then
Set DB = CreateDatabase(App.Path & "\CoolDOC.mdb", dbLangGeneral)
SQL = "create table [CoolDOC]([Root]Text(250),[Key]Text(250),[Valu
e]Text(250),[URL]Text(250))"
DB.Execute SQL
SQL = "create index Root on CoolDoc([Root],[Key])"
DB.Execute SQL
End If
Me.Top = 0
Me.Left = 0
Dim strLast1
Dim strLast2
Set DB = OpenDatabase(App.Path & "\cooldoc.mdb")
Set RS = DB.OpenRecordset("select * from cooldoc order by root,key")
Num1 = 0
Num2 = 0
Num3 = 0
strLast1 = ""
strLast2 = ""
TVDOC.Nodes.Add , , "R", "文档管理"
Do While Not RS.EOF()
If strLast1 <> RS(0) Then
Num1 = Num1 + 1
TVDOC.Nodes.Add "R", tvwChild, "C1" & Trim5(Num1) & RS(0), RS(
0)
strLast1 = RS(0)
End If
If RS("Key") <> "" Then
If strLast2 <> RS(1) Then
Num2 = Num2 + 1
TVDOC.Nodes.Add "C1" & Trim5(Num1) & RS(0), tvwChild, "C2"
& Trim5(Num2) & RS(1), RS(1)
End If
If RS(2) <> "" Then
Num3 = Num3 + 1
TVDOC.Nodes.Add "C2" & Trim5(Num2) & RS(1), tvwChild, "C3"
& Trim5(Num3) & RS(3), RS(2)
End If
End If
strLast2 = RS(1)
RS.MoveNext
Loop
Exit Sub
Errhandle:
MsgBox "出错原因：" & Err.Description
End Sub
Private Sub mnuDelete_Click()
cmdDelete_Click
End Sub
Private Sub mnuNew_Click()
cmdNew_Click
End Sub
Private Sub TVDOC_afterL1abelEdit(Cancel As Integer)
End Sub
Private Sub TVDOC_AfterLabelEdit(Cancel As Integer, NewString As Strin
g)
On Error GoTo Errhandle
Dim RSTemp As Recordset
If Cancel = 0 Then
If MsgBox("真的要改变吗？", vbYesNo, "") = vbNo Then
Cancel = 1
Else
'在此改正
Select Case Left(TVDOC.SelectedItem.Key, 2)
Case "R"
MsgBox "此处为根结点，不能改名！"
Case "C1"
Set RSTemp = DB.OpenRecordset("select * from cooldoc w
here root='" & NewString & "'")
If RSTemp.EOF() Then
Set RSTemp = DB.OpenRecordset("select * from coold
oc where root='" & TVDOC.SelectedItem & "'")
Do While Not RSTemp.EOF()
RSTemp.Edit
RSTemp(0) = NewString
RSTemp.Update
RSTemp.MoveNext
Loop
TVDOC.SelectedItem.Key = Left(TVDOC.SelectedItem.K
ey, 7) & NewString
Else
MsgBox "要改的名字已经存在，请重新选择！"
Cancel = 1
End If
Case "C2"
Set RSTemp = DB.OpenRecordset("select * from cooldoc w
here root='" & TVDOC.SelectedItem.Parent & "' and key='" & NewString &
"'")
If RSTemp.EOF() Then
Set RSTemp = DB.OpenRecordset("select * from coold
oc where root='" & TVDOC.SelectedItem.Parent & "' and key='" & TVDOC.S
electedItem & "'")
Do While Not RSTemp.EOF()
RSTemp.Edit
RSTemp(1) = NewString
RSTemp.Update
RSTemp.MoveNext
Loop
TVDOC.SelectedItem.Key = Left(TVDOC.SelectedItem.K
ey, 7) & NewString
Else
MsgBox "要改的名字已经存在，请重新选择！"
Cancel = 1
End If
Case "C3"
Set RSTemp = DB.OpenRecordset("select * from cooldoc w
here root='" & TVDOC.SelectedItem.Parent.Parent & "' and key='" & TVDO
C.SelectedItem.Parent & "' and value='" & NewString & "'")
If RSTemp.EOF() Then
Set RSTemp = DB.OpenRecordset("select * from coold
oc where root='" & TVDOC.SelectedItem.Parent.Parent & "' and key='" &
TVDOC.SelectedItem.Parent & "' and value='" & TVDOC.SelectedItem & "'"
)
Do While Not RSTemp.EOF()
RSTemp.Edit
RSTemp(2) = NewString
RSTemp.Update
RSTemp.MoveNext
Loop
TVDOC.SelectedItem.Key = Left(TVDOC.SelectedItem.K
ey, 7) & NewString
Else
MsgBox "要改的名字已经存在，请重新选择！"
Cancel = 1
End If
End Select
End If
End If
Exit Sub
Errhandle:
MsgBox "出错原因：" & Err.Description
End Sub
Private Sub TVDOC_DblClick()
On Error GoTo Errhandle
If Left(TVDOC.SelectedItem.Key, 2) = "C3" Then
txtURL = Trim7(TVDOC.SelectedItem.Key)
If Trim(Trim7(TVDOC.SelectedItem.Key)) = "" Then
txtURL = "未指定文件！"
MsgBox "未指定文件！"
Else
If Dir(txtURL) = "" Then
txtURL = txtURL & "(没找到)"
MsgBox "所指文件未找到！"
Else
oleDOC.CreateLink txtURL
End If
End If
End If
Exit Sub
Errhandle:
MsgBox "不是一个合法的WORD文件！"
End Sub
Private Sub TVDOC_KeyDown(KeyCode As Integer, Shift As Integer)
On Error GoTo Errhandle
If KeyCode = 13 Then
TVDOC_DblClick
End If
Exit Sub
Errhandle:
MsgBox "出错原因：" & Err.Description
End Sub
Private Sub TVDOC_KeyUp(KeyCode As Integer, Shift As Integer)
On Error GoTo Errhandle
If Left(TVDOC.SelectedItem.Key, 2) = "C3" Then
frameURL.Enabled = True
Else
frameURL.Enabled = False
End If
Exit Sub
Errhandle:
MsgBox "出错原因：" & Err.Description
End Sub
Private Sub TVDOC_MouseUp(Button As Integer, Shift As Integer, x As Si
ngle, y As Single)
On Error GoTo Errhandle
If Left(TVDOC.SelectedItem.Key, 2) = "C3" Then
frameURL.Enabled = True
Else
frameURL.Enabled = False
End If
If Button = 2 Then
PopupMenu mnuPop
End If
Exit Sub
Errhandle:
MsgBox "出错原因：" & Err.Description
End Sub
是否可行，请大家试一下就好了。
--
峥嵘软件室
http://go.163.com/~zrsoft http://zrsoft.8u8.com
[email protected]
欢迎首页连接！
※ 来源:．月光软件站 http://www.moon-soft.com．[FROM: 202.96.40.13]
|
|