Sub CalEnter2(RainName)
Combo_nm = RainName
combo_year_Click
End Sub
Private Sub Form_Load()
Dim j As Integer
Dim Temp
SetDb
Set Rst2 = New ADODB.Recordset
Rst2.Open "RAINSTAT", Cnn
While Not Rst2.EOF
Combo_nm.AddItem Rst2("rainstatnm")
Rst2.MoveNext
Wend
combo_year = Year(Date) - 1
For j = year0 To Year(Date) - 1
combo_year.AddItem j
Next j
Rst2.MoveFirst
Temp = Rst2("rainstatnm")
Combo_nm.ListIndex = 0
'从外部调用这个FORM
Gflag = False
If GisCD <> "" Then
Gflag = True
Set Rst2 = New ADODB.Recordset
Rst2.Open "select * from RAINSTAT where trim(rainstatcd)='" & Trim(GisCD) & "'", Cnn
On Error Resume Next
Temp = Rst2("rainstatnm")
If err.Number > 0 Then
MsgBox "调用错误，返回"
Unload Me
End If
Combo_nm.Enabled = False
End If
'Rst2.Close
CalEnter2 Temp
End Sub
Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
Dim strvalid As String
strvalid = "0123456789."
If KeyAscii > 26 Then
If InStr(strvalid, Chr(KeyAscii)) = 0 Then
KeyAscii = 0
End If
End If
If KeyAscii = 13 Then
If Index < 11 Then
Text1(Index + 1).SetFocus
End If
If Index = 11 Then
cmdjisuan(0).SetFocus
End If
If Index = 12 Then
cmdSubmit(1).SetFocus
End If
End If
End Sub
程序还用到公用模块代码：
Public Rst1 As ADODB.Recordset '记录集，和set联合使用
Public Rst2 As ADODB.Recordset '记录集，和set联合使用
Public Const year0 = 1950 '最早记录年份
Public GisCD As String 'GIS调用的计算分区号
Public Gflag As Boolean '判断是否为GIS调用
Public Sub SetDb()
Dim fpath2
Set Cnn = New ADODB.Connection
fpath2 = "DBQ=\\WEBGIS\share\降水量文件\raindb.mdb;DefaultDir=c:\VB\demo;Drive r={Microsoft Access Driver (*.mdb)};DriverId=281;FIL=MS Access;FILEDSN=C:\Program Files\Common Files\ODBC\Data Sources\test00.dsn;MaxBufferSize=2048;MaxScanRows =8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"
Cnn.Open "Provider=MSDASQL.1;Persist Security Info=False;Extended Properties=" & fpath2
End Sub
十 文件处理
用open方法读文件
open s1 for input as #1
do while not eof(1)
line input #1, s2
msgbox s2
loop
close #1
用open方法写文件
重写
open s1 for output as #1
print #1, s2
close #1
附加
open s1 for append as #1
print #1, s2
close #1
用FSO对象读写文件
使用FSO对象前要引用Microsoft Scripting Runtime
Dim fso As New FileSystemObject
Dim ts1, ts2 As TextStream
Set ts1 = fso.OpenTextFile(fs1, ForReading)
Set ts2 = fso.OpenTextFile(fs2, ForWriting)
i = 0
Do While Not ts1.AtEndOfStream
s0 = ts1.ReadLine
ts2.WriteLine s0
i = i + 1
Loop
m = i
ts1.Close
ts2.Close
删除文件
Dim fso As New FileSystemObject
fso.DeleteFile fname1
或
Set File2 = fso.GetFile(t1)
File2.Delete
文件更名
把文件t1换名变成t2
t1 = "c:\logs\station.dbf..dbf"
t2 = "c:\logs\station1.dbf"
If fso.FileExists(t1) Then
Set File2 = fso.GetFile(t1)
If Not fso.FileExists(t2) Then
File2.Move t2
End If
Else
MsgBox "数据库文件" & t1 & "不存在！"
End
End If
复制文件
把文件t1复制成t2
t1 = "c:\logs\station.dbf..dbf"
t2 = "c:\logs\station1.dbf"
If fso.FileExists(t1) Then
Set File2 = fso.GetFile(t1)
If Not fso.FileExists(t2) Then
File2.Copy t2
End If
Else
MsgBox "数据库文件" & t1 & "不存在！"
End
End If
删除过期文件
添加File1控件，用来管理所有文件。先要设File1.Path
For i = 0 To File1.ListCount - 1
fn = File1.Path + "\" + File1.List(i)
Set File2 = fso.GetFile(fn)
tt = File2.DateLastModified
If today - tt > 10 Then ‘删除10天前的文件
File2.Delete
End If
Next
十一 收发E-mail
发送E-mail
调用: 【部件】下的Microsoft MAPI Control 6.0
放置控件: Form1:Command1, MAPISession1, MAPIMessages1
属性设置: 〖MAPISession1.名称〗=MAPIS，〖MAPIMessages1.名称〗=MAPIM
说明: 1. MAPISession控件用来进行联接和登录，MAPIMessages控件用来进行收发E-mail的操作。
2. 发送时向MAPIMessages.MsgNoteText输入E-mail内容。要输入多行，用MAPIMessages.MsgNoteText = line1 & vbCrLf & line2 即可。
代码:
Private Sub Command1_Click()
With MAPIS
.DownLoadMail = True '使用开机下载
.LogonUI = True '发送地址不对时可以手工设置
.SignOn '建立会话
End With
With MAPIM
.SessionID = MAPIS.SessionID '用SessionID指定对话序列号,缺省为0
.Compose '写新消息
.RecipAddress = "shuku@waterpub.com.cn" '写收件人地址
.AddressResolveUI = True '使用验证方式
.ResolveName '验证收件人地址
.MsgSubject = "head" '写E-mail主题
.MsgNoteText = "text" '写E-mail内容
.Send '发送
End With
MAPIS.SignOff '结束会话
MsgBox ("发送完毕。")
End Sub
接收E-mail
调用: 【部件】下的Microsoft MAPI Control 6.0
放置控件: Form1:Command1, MAPISession1, MAPIMessages1,Text1,Text2,Text3
属性设置: 〖MAPISession1.名称〗=MAPIS，〖MAPIMessages1.名称〗=MAPIM
说明:：1．本例为接收一份E-mail的例子；
2．要先打开Outlook Express，并自动接受了邮件。程序从Outlook Express的收件箱中读取信件。
代码:
Private Sub Command1_Click()
With MAPIS
.DownLoadMail = True '使用开机下载
.LogonUI = True '发送地址不对时可以手工设置
.SignOn '建立会话
End With
With MAPIM
.SessionID = MAPIS.SessionID '用SessionID指定对话序列号,缺省为0
.Fetch '取信
Text3 = .MsgCount '信件数量
Text1 = .MsgSubject '主题
Text2 = .MsgNoteText '内容
'.Delete '取后删除
End With
MAPIS.SignOff '结束会话
End Sub
接收多封E-mail
放置控件和属性设置同前。
要先打开Outlook Express，并自动接受了邮件。程序从Outlook Express的收件箱中读取信件。
Dim i
Fpath3 = “C:\asp\temp\”
With MAPIS
.DownLoadMail = True
.LogonUI = True
.SignOn
End With
With MAPIM
.SessionID = MAPIS.SessionID
.Fetch
For i = 0 To .MsgCount - 1
.MsgIndex = i
s1 = fpath3 & .MsgSubject
Open s1 For Output As #1
Print #1, .MsgNoteText
Close #1
Next
For i = 0 To .MsgCount - 1
.Delete
Next
End With
MAPIS.SignOff
选择发送多封E-mail
放置控件和属性设置同前,增加Fiel1控件。
利用拨号上网时，要先打开Outlook Express，并已拨号上网，这样速度较快。否则每发送一封要拨一次号。
Option Explicit
Dim fscount, i, j
Dim fs1(200) As String
Dim fso As New FileSystemObject
Dim File2 As File
Function disfile(ss1 As String)
Dim sk
disfile = ""
Open File1.Path & "\" & ss1 For Input As #1
Do While Not EOF(1)
Line Input #1, sk
disfile = disfile & sk & vbCrLf
Loop
Close #1
End Function
Sub MAPIsend()
Dim fs2 As String
With MAPIS
.DownLoadMail = False
.LogonUI = True
.SignOn
End With
With MAPIM
.SessionID = MAPIS.SessionID
.Compose
For i = 0 To fscount - 1
'.MsgIndex = i
.RecipAddress = "wrf@waterpub.com.cn"
.AddressResolveUI = True
.ResolveName
fs2 = fs1(i)
'fs2 = "4bu0020.ppp"
.MsgSubject = fs2
.MsgNoteText = disfile(fs2)
.Send
Next i
End With
MsgBox "发送完毕"
End Sub
Sub mfilemove()
Dim fname1
For i = 0 To fscount - 1
fname1 = File1.Path & "\" & fs1(i)
'MsgBox fname1
fso.DeleteFile fname1
Next
End Sub
Private Sub Command1_Click()
j = 0
For i = 0 To File1.ListCount - 1
If File1.Selected(i) Then
fs1(j) = File1.List(i)
j = j + 1
End If
Next
fscount = j
If fscount < 1 Then
MsgBox "没有要发送的文件！"
Exit Sub
Else
For i = 0 To fscount - 1
fs1(i) = File1.List(i)
Next i
End If
MAPIsend
Mfilemove
MAPIS.SignOff
Unload Me
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Form_Load()
Fpath1=”c:\fxfx\kfb\”
File1.Path = fpath1 & "email"
End Sub
十二 ActiveX控件
建立简单的ActiveX控件
这是一个显示时间的例子。
1．新建一个ActiveX控件工程
放置控件: UserControl1:Frame1,Timer1，Label1(小时)，Label2(分)，Label3(秒)，使框架包容其它控件
属性设置: 〖Timer1.Interval〗=100 'ms
代码:
Private Sub Timer1_Timer()
Label1.Caption = Hour(Time) & ";"
Label2.Caption = Minute(Time) & ";"
Label3.Caption = Second(Time)
End Sub
Private Sub UserControl_Initialize()
Label1.Caption = Hour(Time) & ";"
Label2.Caption = Minute(Time) & ";"
Label3.Caption = Second(Time)
End Sub
然后保存文件，并生成OCX文件。
2．新建一个标准EXE工程，单击【工程】/【部件】，找到刚才生成的“工程1”部件，把它选中，然后从工具箱中把它添加到Form1中。这时就可以看见这个控件已经在运行了。然后就可以发布使用这个控件了。
改进ActiveX控件的接口
在【外接程序】/【外接程序管理器】中选择“ActiveX接口向导”的加载，再打开向导对话框，按照提示去做即可。
发布和应用ActiveX控件
在【外接程序】/【外接程序管理器】中选择“打包和展开向导”的加载，再打开向导对话框，选择【打包】，再选择【Internet】,在选项中选择“发布到没有VB的计算机上”，然后就可以在指定的文件夹中产生一个CAB文件，可以安装到其它计算机上使用。
这时还产生了一个同名的HTML文件，把其上的OBJECT代码拷贝下来，放到其它网页上，就可以在网上应用这个控件了。
建立一个复杂一点的例子
这是一个添加新的属性和方法的例子。
新建一个ActiveX控件工程，放置控件: UserControl1:command1,label1。
打开“ActiveX接口向导”，只选择caption（对应label1）和click（对应Command1），再新建一个属性leftx（对应label1）。
这时在UserControl1自动产生了几段代码，修改如下，然后再用下节的调试方法来进行在线调试。
'设置leftx的属性（用let和get分别设置赋值和被赋值的情况）
Public Property Let leftx(ByVal New_leftx As Integer)
Label1.Left = New_leftx
PropertyChanged "leftx"
End Property
'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get leftx() As Integer
leftx = Label1.Left
End Property
'修改Click事件
Private Sub Command1_Click()
Me.Caption = Me.leftx
Me.leftx = Me.leftx + 50
RaiseEvent Click
End Sub
'添加一个初始值设置（没有大用处，只是练习）
Private Sub UserControl_Initialize()
Me.Caption = ""
End Sub
开发调试
先单击【工程】/【添加工程】，添加一个测试工程；
关闭 UserControl，这时工具箱中出现 UserControl控件，把它加入到Form1中，就可以运行这个程序了。
如果没有测试工程，也可以调用IE运行。
要在网页上加入这个控件，运行时查看HTML源文件，把下列说明复制下来，粘贴到网页中：
<OBJECT classid="clsid:0C174E17-67F5-11D5-98FB-BCF7F45EF11E">
</OBJECT>
其余的语句运行时自动产生。
安装和发布
对于DLL文件，拷贝到一个目录后，在【运行】中键入：
C:\WINDOWS\SYSTEM\REGSVR32.EXE C:\MYASP\ASPPING.DLL
或在NT中：
C:\WINNT\SYSTEM32\REGSVR32.EXE C:\MYASP\ASPPING.DLL
对于OCX文件，则要安装。步骤是：
1．编制程序（ACTIVEX控件）；
2．在【工程】/【工程。。属性】中选“要求许可证关键字”；
3．编译成OCX文件；
4．打包。
十三 总体结构
用Timer控件控制程序运行
放置控件: Form1:Command1,Timer1
属性设置: 〖Timer1.Interval〗=10 '10ms
代码:
Dim i As Integer '循环变量
Dim doflag As Boolean '用户是否按键标志
Sub delay 同前
Private Sub example()
Form1.Print i
delay (500)
i = i + 1
End Sub
Private Sub Command1_Click()
Select Case doflag
Case True
Command1.Caption = "开始"
doflag = False
Cls
Case False
Command1.Caption = "停止"
doflag = True
End Select
End Sub
Private Sub Timer1_Timer() '时钟控件随时检测,如果没有点击
If doflag Then 'Command1(停止),则继续调用example过程
example
End If
End Sub
Private Sub Form_Load()
doflag = False
Command1.Caption = "开始"
End Sub
在过程中调用Form的模式方法
Form2.Show VbModal
在过程中调用Form的后台中断方法
放置控件: Form1:Command1, Form2:Command2
代码:
Private Sub Command1_Click()
Bl = True
Form2.show
Do While Bl do
DoEvents
Loop
End Sub
Private Sub Command2_Click()
Unload Me
Bl = False
End Sub
调用其它窗体中的过程
调用Form2的pp1过程:
Load Form2
Form2.pp1
定时播放提醒声
以下程序每隔10分钟播放提醒声，按COMMAND2停止。
Option Explicit
Dim s1, s2
Dim stopb As Boolean
Sub delay(ss As Long)
Dim start, check
start = Timer
Do
check = Timer
Loop While check < start + ss * 60
End Sub
Private Sub Command1_Click()
Dim i
s1 = "C:\Program Files\Windows Media Player\MPLAYER2.EXE"
s2 = " C:\windows\media\乐曲默认值.wav"
Do While Not stopb
Shell (s1 & s2)
delay 10
DoEvents
Loop
End Sub
Private Sub Command2_Click()
stopb = True
End Sub
Private Sub Form_Load()
stopb = False
End Sub
十四 加密
简单的密码框
放置控件: Form1:Text1,Command1;Form2
属性设置: 〖Form1.Command1.Caption〗=确定
〖Form1.Text1.text〗=""
〖Form2.Command1.Caption〗=Exit
Form1代码:
Private Sub Command1_Click()
If Text1.text = "123" then '设密码为123
Print "You are right!"
Else
Print "Sorry ! Input again."
Text1.Text = "" '清除以前输入内容
End If
Text1.SetFocus '焦点重新回到文本框
End Sub
Form2代码:
Private Sub Command1_Click()
End
End Sub
