用VB实现网上留言板

2003-01-05 20:23 | wolfccb

去年写的文章,希望对VB初学者有帮助。现在看来,既然winme以上的操作系统已经成了主力,把这个程序做成ActiveX的程序会比较好,可以不经过下载,直接在IE中使用,我已经测试通过了。另外,免费的FTP也越来越少了,所以本文只起一个研究探讨的作用。程序中有很多不完善的地方,希望高手跟贴斧正,使这篇文章成为一个教程。


现在有很多网站提供了同学录、留言板等功能,为我们同学之间的联系提供了方便。有很多朋友想自己制作类似的网站,但苦于自己的免费主页空间不支持PHP、ASP和CGI,而且实现这些功能还很费时费力。笔者也有过这种想法,经过尝试,得到了用VB调用Microsoft Internet Transfer Control控件实现同学录、留言板的方法,不敢独享,写出来奉献给大家。
界面设计:如图。几个按钮名称从上到下分别为cmdgetlist、cmdgo、cmdwrite、cmdsend、cmdinfo和cmdclear,三个文本框为txtname、txttitle和txtcontent,另需将Microsoft Internet Transfer Control控件添加到窗体上,设其名称为Inet1。

基本思路:自定义数据类型message, 包含留言的序号、作者和标题三部分,用一随机文件(msglst.dat)存储所有的message, 并用"序号.txt"存储留言正文。当用户读留言列表时,用Inet1的OpenURL方法下载此文件并按倒序逐记录将其显示到list1中。当用户要查看某条留言时(双击list1或输入留言号码后单击cmdgo),在msglst.dat中找到此记录并读取作者和标题显示在txtname和txttitle中,然后下载序号.txt,并显示在txtcontent中。当用户写好留言单击cmdsend时,先更新msglst.dat,然后在"序号.txt"中写入txtcontent中的留言正文,将此二文件用ftp上传到支持ftp的主页空间上。当用户单击cmdinfo查看个人信息时,用inputbox函数获得用户要查询的姓名,然后读取姓名.txt显示到txtcontent中。为了程序简洁,笔者将常用的语句段定义成子过程,希望能对大家的理解带来方便。
程序代码:
'----------
Option Explicit
Private Type message '自定义数据类型:留言
num1 As Integer '留言的序号
title As String * 62 '留言的标题
name As String * 20 '留言的作者
End Type
Public LastRecord As Long '此变量表示最大记录号
Public isbusy As Boolean '此变量用于判断是否有过程在运行
Public doing As Boolean '此变量用于判断Inet1控件是否在工作
'----------
Public Sub listrefresh() '把msglst.dat中的记录显示在list1中
List1.Clear
Dim msg1 As message
With msg1 '初始化msg1变量,否则list1中最后一条显示不正常
.num1 = 0
.title = ""
.name = ""
End With
Dim pointer1 As Long '记录指针
Open "c:\temp\vbbs\msglst.dat" For Random As #1 Len = 84 '用随机方式打开文件,记录长84
Dim index As String * 5
Dim ttarget As Integer
LastRecord = LOF(1) / 84
If LastRecord >= 300 Then ttarget = LastRecord - 300 Else ttarget = 1 '至多显示300条记录
For pointer1 = LastRecord To ttarget Step -1
Get #1, pointer1, msg1 '读一条记录
index = CStr(msg1.num1)
List1.AddItem index + "| " + RTrim(msg1.title) + " " + msg1.name '在list1中增加一条记录
With msg1
.name = ""
.title = ""
.num1 = 0
End With
Next pointer1
Close #1
End Sub
'----------
Public Sub waitftpdone() '此过程用于等待ftp操作完成,否则会发生"仍在执行上一请求"错误
doing = Inet1.StillExecuting
Do While doing
doing = Inet1.StillExecuting
DoEvents
Loop
End Sub
'----------
Public Sub busy() '一过程开始时阻止其他过程开始
Labelstatus.Caption = "正在连接"
cmdgetlist.Enabled = False
cmdgo.Enabled = False
cmdsend.Enabled = False
cmdinfo.Enabled = False
End Sub
'----------
Public Sub free() '一过程结束时允许其他过程开始
Labelstatus.Caption = "空闲"
cmdgetlist.Enabled = True
cmdgo.Enabled = True
cmdinfo.Enabled = True
End Sub

Private Sub Form_load() '程序初始化,建立临时目录
isbusy = False
On Error Resume Next '此处笔者偷了一个大大的懒,有时间的读者可以将此部分完善
MkDir "c:\temp"
MkDir "c:\temp\vbbs"
Kill "c:\temp\vbbs\*.txt"
Kill "c:\temp\vbbs\msglst.dat"
On Error GoTo 0
End Sub
'----------
Private Sub cmdgetlist_Click()
If isbusy = True Then Exit Sub '判断是否有过程在进行中
isbusy = True
Call busy
List1.Clear
Dim msg1 As message
With msg1
.num1 = 0
.title = ""
.name = ""
End With
On Error Resume Next
Kill "c:\temp\vbbs\*.txt"
Kill "c:\temp\vbbs\msglst.dat"
On Error GoTo 0
On Error GoTo msg
Dim bData() As Byte '字节数组
bData() = Inet1.OpenURL("http://go.163.com/msglst.dat", icByteArray) 'icByteArray说明传输的对象是字节而不是字符串(icString)
Open "c:\temp\vbbs\msglst.dat" For Binary Access Write As #1
Put #1, , bData()
Close #1
On Error GoTo 0
Call listrefresh
If List1.ListCount = 0 Then GoTo msg Else Call free '若list1中无记录则报错
isbusy = False
Exit Sub
msg:
MsgBox "无法下载留言列表!", vbExclamation, "错误"
Close #1
Call free
isbusy = False
End Sub
'----------
Private Sub cmdgo_Click()
If isbusy = True Then Exit Sub
isbusy = True
If List1.ListCount = 0 Then GoTo err Else Call busy
Dim intmsg As Integer
If txtindex.Text = "" Then GoTo msg2 Else intmsg = CInt(txtindex.Text)
Dim msg1 As message
With msg1
.name = ""
.title = ""
.num1 = 0
End With
Open "c:\temp\vbbs\msglst.dat" For Random As #1 Len = 84 '显示一条留言的标题和作者
If intmsg > LOF(1) / 84 Then GoTo msg
Get #1, intmsg, msg1
txttitle.Text = msg1.title
txtname.Text = msg1.name
Close #1
txtcontent.Text = Inet1.OpenURL("http://go.163.com/msg/" + CStr(intmsg) + ".txt", icString) '读取留言正文
If txtcontent.Text = "" Then GoTo msg
Call free
txtcontent.Locked = True
isbusy = False
Exit Sub
msg:
Close #1
MsgBox "无法下载留言!", vbExclamation, "错误"
Call free
isbusy = False
Exit Sub
msg2:
MsgBox "请输入留言号码!", vbExclamation, "错误"
Call free
isbusy = False
Exit Sub
err:
MsgBox "请先下载留言列表!", vbExclamation, "错误"
Call free
isbusy = False
End Sub
Private Sub cmdsend_Click()
If List1.ListCount = 0 Then GoTo err2
If isbusy = True Then Exit Sub
isbusy = True
Call busy
On Error Resume Next
Kill "c:\temp\vbbs\*.txt"
On Error GoTo 0
Dim bData() As Byte '更新列表文件
bData() = Inet1.OpenURL("http://go.163.com/msglst.dat", icByteArray)
Open "c:\temp\vbbs\msglst.dat" For Binary Access Write As #1
Put #1, , bData()
LastRecord = LOF(1) / 84
Close #1
If txtcontent.Text = "" Or txttitle.Text = "" Or txtname.Text = "" Then GoTo err
Dim msgtosend As message
Dim pointer2 As Long
LastRecord = LastRecord + 1
With msgtosend
.name = txtname.Text
.title = txttitle.Text
.num1 = LastRecord
End With
Open "c:\temp\vbbs\msglst.dat" For Random As #1 Len = 84
Put #1, LastRecord, msgtosend
Close #1
Dim split As Byte, spacec As Byte
split = 124
spacec = 32
Open "c:\temp\vbbs\msglst.dat" For Binary As #1
Put #1, LastRecord * 84 - 21, split
Put #1, LastRecord * 84 - 20, spacec
Close #1
Open "c:\temp\vbbs\" + CStr(LastRecord) + ".txt" For Output As #1
Print #1, txtcontent.Text
Close #1
On Error GoTo err3
With Inet1 '设置ftp信息
.URL = ftp://ftp1.go.163.com '服务器地址
.UserName = "username" '用户名
.Password = Mid("andy", 1, 1) + Mid("computer", 3, 1) + Mid("bomb", 2, 1) + Mid("humanbeing", 6, 1) + Mid("121", 1, 1) + Mid("sleeping", 7, 2) '为避免有人从exe中得到密码,采用逐字分散的方法设置密码
End With
Inet1.Execute , "put c:\temp\vbbs\msglst.dat /msglst.dat" '上传列表文件
Call waitftpdone
Inet1.Execute , "put c:\temp\vbbs\" + CStr(LastRecord) + ".txt" + " /msg/" + CStr(LastRecord) + ".txt" '上传留言正文
Call waitftpdone
Inet1.Execute , "close" '关闭连接,此过程必不可少!
Call waitftpdone
On Error GoTo 0
Call listrefresh
If List1.ListCount = 0 Then GoTo msg Else Call free
txtcontent.Locked = True
isbusy = False
Exit Sub
msg:
MsgBox "无法下载留言列表!", vbExclamation, "错误"
Close #1
cmdsend.Enabled = True
Call free
txtcontent.Locked = True
txtname.Locked = True
txttitle.Locked = True
isbusy = False
Exit Sub
err:
MsgBox "请在留言框内输入必要的内容!", vbExclamation, "错误"
cmdsend.Enabled = True
Call free
isbusy = False
Exit Sub
err2:
MsgBox "请先下载留言列表!", vbExclamation, "错误"
cmdsend.Enabled = True
Call free
isbusy = False
Exit Sub
err3:
MsgBox "留言上传失败!", vbExclamation, "错误"
cmdsend.Enabled = True
Call free
LastRecord = LastRecord - 1
isbusy = False
End Sub
'----------
Private Sub cmdinfo_Click()
If isbusy = True Then Exit Sub
isbusy = True
txtcontent.Text = ""
Dim sname As String
sname = InputBox("用拼音输入您要查询的姓名,请使用小写字母,不加空格(如:dongshen,litieyuan):", "查看个人信息")
If sname = "" Then GoTo msg2
txtname.Text = "管理员"
txttitle.Text = " " + sname + " 的个人信息"
Call busy
txtcontent.Text = Inet1.OpenURL("http://go.163.com/info/" + sname + ".txt") '读取个人信息
If txtcontent.Text = "" Then GoTo msg
Call free
cmdsend.Enabled = False
isbusy = False
Exit Sub
msg:
MsgBox "无法调用个人信息!", vbExclamation, "错误"
Call free
isbusy = False
Exit Sub
msg2:
MsgBox "请输入您要查询的姓名!", vbExclamation, "错误"
Call free
isbusy = False
End Sub
'----------
Private Sub cmdwrite_Click()
txtcontent.Text = ""
txtcontent.Locked = False
txttitle.Text = ""
txttitle.Locked = False
txtname.Text = ""
txtname.Locked = False
cmdsend.Enabled = True
End Sub
'----------
Private Sub Cmdclear_Click()
Call cmdwrite_Click
End Sub
'----------
Private Sub Form_Unload(Cancel As Integer)
Dim check As Boolean
Do While check '为了安全一定要检查是否所有的任务都已完成
check = isbusy
DoEvents
Loop
On Error Resume Next '删除临时文件
Kill "c:\temp\vbbs\*.txt"
Kill "c:\temp\vbbs\msglst.dat"
On Error GoTo 0
End Sub
'----------
Private Sub List1_DblClick()
If isbusy = True Then Exit Sub
isbusy = True
Call busy
Dim msg1 As message
With msg1
.name = ""
.title = ""
.num1 = 0
End With
Open "c:\temp\vbbs\msglst.dat" For Random As #1 Len = 84 '显示留言的标题和作者
Get #1, LastRecord - List1.ListIndex, msg1
txttitle.Text = msg1.title
txtname.Text = msg1.name
Close #1
txtcontent.Text = Inet1.OpenURL("http://go.163.com/msg/" + CStr(LastRecord - List1.ListIndex) + ".txt") '显示留言正文
If txtcontent.Text = "" Then GoTo msg
Call free
cmdsend.Enabled = False
txtcontent.Locked = True
txtname.Locked = True
txttitle.Locked = True
isbusy = False
Exit Sub
msg:
MsgBox "无法下载留言!", vbExclamation, "错误"
Call free
isbusy = False
Exit Sub
End Sub
'----------
Private Sub txtindex_KeyPress(KeyAscii As Integer) '此文本框仅允许输入数字
If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then
KeyAscii = 0
Beep
End If
End Sub


此程序在VB6.0企业版+Win98\WinMe\Win2000下调试通过。使用的ftp空间是网易的免费个人主页。另外,由于Inet控件只能用binary方式传输文件,所以上传个人信息时最好也将文件按binary方式上传,否则换行符会不正常。
此程序系笔者在仓促之际完成,一定有不足之处,欢迎朋友们不吝赐教。


-
喊天天崩,唤地地裂!