📄 frmdocument.frm
字号:
BackColor = &H00FFF3CE&
Caption = "作者："
Height = 195
Index = 6
Left = 120
TabIndex = 10
Top = 3360
Width = 735
End
Begin VB.Label Label1
BackColor = &H00FFF3CE&
Caption = "内容介绍："
Height = 195
Index = 5
Left = 120
TabIndex = 9
Top = 2400
Width = 1095
End
Begin VB.Label Label1
BackColor = &H00FFF3CE&
Caption = "年级："
Height = 200
Index = 3
Left = 120
TabIndex = 8
Top = 1680
Width = 615
End
Begin VB.Label Label1
BackColor = &H00FFF3CE&
Caption = "编号："
Height = 195
Index = 2
Left = 120
TabIndex = 7
Top = 1320
Width = 735
End
Begin VB.Label Label1
BackColor = &H00FFF3CE&
Caption = "科目："
Height = 195
Index = 1
Left = 120
TabIndex = 6
Top = 960
Width = 615
End
Begin VB.Label labInfo
BackColor = &H00FFF3CE&
ForeColor = &H000000FF&
Height = 200
Index = 0
Left = 120
TabIndex = 5
Top = 700
Width = 1850
End
Begin VB.Label Label1
BackColor = &H00FFF3CE&
Caption = "标题："
Height = 200
Index = 0
Left = 120
TabIndex = 4
Top = 480
Width = 735
End
Begin VB.Label labBG
BackColor = &H00FFF3CE&
Height = 6735
Left = 0
TabIndex = 3
Top = 405
Width = 1995
End
End
Attribute VB_Name = "frmDocument"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Const cstW = 2000
Dim ListViewLeft As Long
Dim Mysql As String
Public lei As Integer
Public MyIndex As Integer
Public Sub Init(ByVal sql As String)
ListView1.ListItems.Clear
If sql = "" Then
sql = Mysql
Else
Mysql = sql
End If
con.Open
rs.Open sql, con, adOpenKeyset, adLockPessimistic
StatusBar1.Panels(2).Text = "共有" + Me.Caption + "资源 " + CStr(rs.RecordCount)
If rs.AbsolutePosition = adPosBOF Or rs.AbsolutePosition = adPosUnknown Then
StatusBar1.Panels(1).Text = "当前记录： 0"
Else
StatusBar1.Panels(1).Text = "当前记录： " + CStr(rs.AbsolutePosition)
End If
Dim itmX As ListItem
While Not rs.EOF
Set itmX = ListView1.ListItems.Add()
If rs("title") <> "" Then itmX.Text = rs("title")
itmX.Icon = 1
itmX.SmallIcon = 1
If rs("kemu") <> "" Then itmX.SubItems(1) = rs("kemu")
If rs("id") <> "" Then itmX.SubItems(2) = rs("id")
If rs("nianji") <> "" Then itmX.SubItems(3) = rs("nianji")
If rs("type") <> "" Then itmX.SubItems(4) = rs("type")
If rs("jieshao") <> "" Then itmX.SubItems(5) = rs("jieshao")
If rs("zuozhe") <> "" Then itmX.SubItems(6) = rs("zuozhe")
If rs("gongju") <> "" Then itmX.SubItems(7) = rs("gongju")
If rs("geshi") <> "" Then itmX.SubItems(8) = rs("geshi")
If rs("size") <> "" Then itmX.SubItems(9) = rs("size")
If rs("date") <> "" Then itmX.SubItems(10) = rs("date")
If rs.AbsolutePosition Mod 100 = 0 Then DoEvents
rs.MoveNext
Wend
rs.Close
con.Close
fl = 0
End Sub
Private Sub Form_Resize()
Dim h As Integer, w As Integer
h = Me.Height - 1200
w = Me.Width - 150 - ListViewLeft
If h > 0 And w > 0 Then
ListView1.Left = ListViewLeft
ListView1.Height = h
ListView1.Width = w
labBG.Height = h
End If
Dim i As Integer, n As Integer
If labBG.Height > 5100 Then
n = Int((labBG.Height - 5100) / 2)
n = n - (Label1(0).Top - 480)
For i = 0 To 10
labInfo(i).Top = labInfo(i).Top + n
Label1(i).Top = Label1(i).Top + n
Next
Else
n = Label1(0).Top - 480
For i = 0 To 10
labInfo(i).Top = labInfo(i).Top - n
Label1(i).Top = Label1(i).Top - n
Next
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call SetFlag(MyIndex, lei)
End Sub
Private Sub ListView1_DblClick()
MyUpData 0
End Sub
Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
StatusBar1.Panels(1).Text = "当前记录： " + CStr(Item.Index)
If Not (ListView1.SelectedItem Is Nothing) Then
If ListView1.View <> lvwReport Then
labInfo(0) = Item.Text
For i = 1 To 10
labInfo(i) = Item.SubItems(i)
Next
End If
End If
End Sub
Private Sub ListView1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
PopupMenu fMainForm.mypop
End If
End Sub
Public Sub munViwe(Index As Integer)
Select Case Index
Case 1
ListView1.View = lvwIcon
ListViewLeft = cstW
Case 2
ListView1.View = lvwList
ListViewLeft = cstW
Case 3
ListView1.View = lvwReport
ListViewLeft = 0
End Select
ListView1.SelectedItem = Nothing
If ListView1.View <> lvwReport Then
If Not (ListView1.SelectedItem Is Nothing) Then
labInfo(0) = ListView1.SelectedItem.Text
For i = 1 To 9
labInfo(i) = ListView1.SelectedItem.SubItems(i)
Next
End If
End If
Call Form_Resize
End Sub
Public Sub MyUpData(Index As Integer)
On Error GoTo FuncError
Dim sql As String
Select Case Index
Case 0 '打开
If Not (ListView1.SelectedItem Is Nothing) Then
con.Open
sql = "select * from info where id=" + ListView1.SelectedItem.SubItems(2)
rs.Open sql, con, adOpenKeyset, adLockPessimistic
If rs.AbsolutePosition = 1 Then
Dim strFileFullName As String
strFileFullName = App.Path + "\" + rs("filedir") + rs("filename")
If ShellExecute(0&, "open", strFileFullName, vbNullString, vbNullString, SW_SHOWNORMAL) = 0 Then
MsgBox "打开 ." + rs("geshi") + "格式的文件失败", , "没有打开"
End If
End If
Else
MsgBox "请先选择！", vbOKOnly, "提示"
End If
Case 1 '修改
If Not (ListView1.SelectedItem Is Nothing) Then
Dim frmG As frmGai
Set frmG = New frmGai
Load frmG
frmG.txtTitle.Text = ListView1.SelectedItem.Text
If ListView1.SelectedItem.SubItems(1) <> "" Then frmG.cmbKemu.Text = ListView1.SelectedItem.SubItems(1)
If ListView1.SelectedItem.SubItems(3) <> "" Then frmG.cmbNianji.Text = ListView1.SelectedItem.SubItems(3)
frmG.labType.Caption = ListView1.SelectedItem.SubItems(4)
frmG.txtJieshao.Text = ListView1.SelectedItem.SubItems(5)
frmG.txtZuozhe.Text = ListView1.SelectedItem.SubItems(6)
frmG.cmbGongju.Text = ListView1.SelectedItem.SubItems(7)
frmG.labFileSize.Caption = ListView1.SelectedItem.SubItems(9)
frmG.Show vbModal
If frmG.OK Then
'修改数据
con.Open
sql = "select * from info where id=" + ListView1.SelectedItem.SubItems(2)
rs.Open sql, con, adOpenKeyset, adLockPessimistic
If rs.AbsolutePosition = 1 Then
rs("kemu") = frmG.cmbKemu.Text
rs("nianji") = frmG.cmbNianji.Text
rs("title") = frmG.txtTitle.Text
rs("zuozhe") = frmG.txtZuozhe.Text
rs("jieshao") = frmG.txtJieshao
rs("gongju") = frmG.cmbGongju.Text
Dim itmX As ListItem
Set itmX = ListView1.SelectedItem
If rs("title") <> "" Then itmX.Text = rs("title")
If rs("kemu") <> "" Then itmX.SubItems(1) = rs("kemu")
If rs("id") <> "" Then itmX.SubItems(2) = rs("id")
If rs("nianji") <> "" Then itmX.SubItems(3) = rs("nianji")
If rs("jieshao") <> "" Then itmX.SubItems(4) = rs("type")
If rs("jieshao") <> "" Then itmX.SubItems(5) = rs("jieshao")
If rs("zuozhe") <> "" Then itmX.SubItems(6) = rs("zuozhe")
If rs("gongju") <> "" Then itmX.SubItems(7) = rs("gongju")
If rs("geshi") <> "" Then itmX.SubItems(8) = rs("geshi")
If rs("size") <> "" Then itmX.SubItems(9) = rs("size")
If rs("date") <> "" Then itmX.SubItems(10) = rs("date")
rs.Update
End If
End If
Unload frmG
Else
MsgBox "请先选择！", vbOKOnly, "提示"
End If
Case 2 '撤除
If Not (ListView1.SelectedItem Is Nothing) Then
Dim intYes As Integer
intYes = MsgBox("确实要撤除当前记录吗？", vbYesNo Or vbQuestion, "询问")
If intYes = vbYes Then
con.Open
sql = "select * from info where id=" + ListView1.SelectedItem.SubItems(2) + ""
rs.Open sql, con, adOpenKeyset, adLockPessimistic
If rs.AbsolutePosition <> adPosBOF Or rs.AbsolutePosition <> adPosUnknown Then
rs("deldate") = CStr(Now)
rs.Update
End If
ListView1.ListItems.Remove (ListView1.SelectedItem.Index)
End If
Else
MsgBox "请先选择！", vbOKOnly, "提示"
End If
Case 3 '另存为
If Not (ListView1.SelectedItem Is Nothing) Then
con.Open
sql = "select * from info where id=" + ListView1.SelectedItem.SubItems(2)
rs.Open sql, con, adOpenKeyset, adLockPessimistic
If rs.AbsolutePosition = 1 Then
myNext:
dlgSave.DialogTitle = "另存为"
dlgSave.FileName = rs("filename")
dlgSave.Filter = rs("geshi") + "文档(*." + rs("geshi") + ")|*." + rs("geshi")
dlgSave.ShowSave
If Right(dlgSave.FileName, Len(rs("geshi")) + 1) = ("." + rs("geshi")) Then
strFileFullName = dlgSave.FileName
Else
strFileFullName = dlgSave.FileName + "." + rs("geshi")
End If
If IsFileExists(strFileFullName) Then
intYes = MsgBox(strFileFullName + "已经存在，要替换吗？", vbYesNo Or vbQuestion, "询问")
If intYes <> vbYes Then GoTo myNext
End If
strExistsFileFullName = App.Path + "\" + rs("filedir") + rs("filename")
CopyFile strExistsFileFullName, strFileFullName, 0
uCopyFile App.Path + "\" + rs("filedir"), FileDir(strFileFullName), strExistsFileFullName
End If
Else
MsgBox "请先选择！", vbOKOnly, "提示"
End If
End Select
If rs.State Then rs.Close
If con.State Then con.Close
Exit Sub
FuncError:
If IsObject(frmG) And Not (frmG Is Nothing) Then Unload frmG
If rs.State Then rs.Close
If con.State Then con.Close
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Index
Case 1
MyUpData 1
Case 2
MyUpData 2
Case 3
MyUpData 3
Case 4
munViwe (Button.Index - 3)
Case 5
munViwe (Button.Index - 3)
Case 6
munViwe (Button.Index - 3)
End Select
End Sub
Private Sub uCopyFile(ByVal strYuan As String, ByVal strMubiao As String, ByVal strPaiChu As String)
On Error Resume Next
Dim Win_Find As WIN32_FIND_DATA
Dim strFileName As String
Dim hFindFile As Long, se As Long
If Not IsFileExists(strMubiao) Then MkDir strMubiao
hFindFile = FindFirstFile(strYuan + "*.*", Win_Find)
If hFindFile <> -1 Then
se = 1
While se <> 0
strFileName = ustr(Win_Find.cFileName)
If (Int(Win_Find.dwFileAttributes / 16) Mod 2 = 1) And (Int(Win_Find.dwFileAttributes / 4) Mod 2 = 0) And strFileName <> "." And strFileName <> ".." Then Call uCopyFile(strYuan + strFileName + "\", strMubiao + strFileName + "\", "")
If (Int(Win_Find.dwFileAttributes / 16) Mod 2 = 0) And (Int(Win_Find.dwFileAttributes / 4) Mod 2 = 0) Then
If (strYuan + strFileName) <> strPaiChu Then
If IsFileExists(strMubiao + strFileName) Then
Dim intYes As Integer
intYes = MsgBox("该资源的一个相关文件" + strMubiao + strFileName + "已经存在，要替换吗？", vbYesNo Or vbQuestion, "询问")
If intYes <> vbYes Then
GoTo donotCopy
End If
End If
CopyFile strYuan + strFileName, strMubiao + strFileName, 1
End If
donotCopy:
End If
se = FindNextFile(hFindFile, Win_Find)
Wend
FindClose hFindFile
End If
End Sub
Private Function ustr(ByVal Mystr As String) As String
Dim i As Integer
i = InStr(1, Mystr, Chr(0))
If i = 0 Then
ustr = Mystr
Else
ustr = Left(Mystr, i - 1)
End If
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -