加密Form
放置控件: Form1:Text1,Command1;Form2
属性设置: 〖Form1.Command1.Caption〗=确定
〖Form1.Text1.text〗=""
〖Form2.Command1.Caption〗=Exit
Form1代码:
Dim s1 As Integer
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If Text1 = "123" Then '密码为123
Form1.Hide
Form2.Show
Else
If s1 = 3 Then '只能试3次
MsgBox ("密码错误,系统退出!")
Unload Me
Else
MsgBox ("输入错!请重新输入密码:")
Text1 = ""
s1 = s1 + 1
End If
End If
End If
End Sub
Private Sub Form_Load()
Text1 = ""
s1 = 1
End Sub
十五 其它编程
调用外部程序
本例用shell调用记事本程序，在其中写入几行字后保存，最后返回VB。
放置控件: Form1:Text1,Command1
代码：
Private Sub Command1_Click()
Shell ("C:\PWIN98\NOTEPAD.EXE"), 1
'AppActivate "无标题 - 记事本" ’指定窗口
SendKeys "The text1 is : ", True
SendKeys "{ENTER}", True
SendKeys Text1, True
SendKeys "%(F)", True ’按Alt+F
SendKeys "X", True ’按X退出记事本
SendKeys "{ENTER}", True
SendKeys "123", True ’输入文件名
SendKeys "{ENTER}", True
SendKeys "Y", True
Unload Me
End Sub
运行时先在文本框中输入一行字，再按Command1，就可以把这行字和前面的提示写到一个名为“123”的文件中了。
调用VB外部程序并传递参数
建立工程2，其中FORM2代码为：
Private Sub Command1_Click()
MsgBox "g2=" & Command()
End Sub
再建立工程1，其中FORM1代码为：
Private Sub Command1_Click()
Shell ("C:\VB\LIAN\工程2.exe cmmm 123456"), 1
MsgBox "ok"
End Sub
动态调整各测站的加权值
工程由FORM0和FORM1组成；FORM0根据选择流域值，再调用FORM1；FORM1先根据流域值查流域代码，根据代码查找测站数，然后动态产生各控件和FORM尺寸。拉动SLIDER控件可以调整各测站的权重。
FORM0：DATA1，COMMAND1，COMBO1
Private Sub Combo1_Click()
Data1.RecordSource = "SELECT * FROM HYDNET WHERE HYDNETNM='" & Combo1 & "'"
Data1.Refresh
SELHYDNET = Data1.Recordset!HYDNETCD
Data1.Recordset.Close
End Sub
Private Sub Command1_Click()
'Form0.Hide
Form1.Show
End Sub
Private Sub Form_Load()
Data1.RecordSource = "HYDNET"
Data1.Refresh
Do While Not Data1.Recordset.EOF
Combo1.AddItem Data1.Recordset!HYDNETNM
Data1.Recordset.MoveNext
Loop
End Sub
FORM1：产生SLIDER1、LABEL2、TEXT1数组（包括第一个控件），再产生一个标题LABEL1、DATA1、COMMAND1、COMMAND2；
Option Explicit
Dim Imax '控件数（从0开始）
Const Smax = 100 '权重总计
Const Topy = 600 '每个控件间距
Private Sub Command1_Click() '关闭
Unload Me
End Sub
Private Sub Form_Load()
Dim j, Stemp
Data1.RecordSource = "SELECT * FROM RAINSTAT WHERE HYDNETCD='" & SELHYDNET & "'"
Data1.Refresh
Imax = 0
Do While Not Data1.Recordset.EOF
Imax = Imax + 1
Data1.Recordset.MoveNext
Loop
If Imax > 1 And Imax < 21 Then
Data1.Refresh
Label2(0) = Data1.Recordset!RAINSTATNM
If Imax < 10 Then
Form1.Width = 5800
Form1.Height = 4500 + Topy * (Imax - 2)
For j = 1 To Imax - 1
Load Slider1(j)
Slider1(j).Left = 1000
Slider1(j).Top = 1200 + Topy * j
Slider1(j).Visible = True
Load Text1(j)
Text1(j).Left = 4200
Text1(j).Top = 1200 + Topy * j
Text1(j).Visible = True
Data1.Recordset.MoveNext
Load Label2(j)
Label2(j).Left = 240
Label2(j).Top = 1300 + Topy * j
Label2(j).Caption = Data1.Recordset!RAINSTATNM
Label2(j).Visible = True
Next j
Command2.Left = 1400
Command2.Top = 3000 + Topy * (Imax - 2)
Command1.Left = 3300
Command1.Top = 3000 + Topy * (Imax - 2)
Else '如果控件数大于10，则要分2栏
Form1.Width = 11500
Form1.Height = 4500 + Topy * 9
Label1.Left = 4500
For j = 1 To 9
Load Slider1(j)
Slider1(j).Left = 1000
Slider1(j).Top = 1200 + Topy * j
Slider1(j).Visible = True
Load Text1(j)
Text1(j).Left = 4200
Text1(j).Top = 1200 + Topy * j
Text1(j).Visible = True
Data1.Recordset.MoveNext
Load Label2(j)
Label2(j).Left = 240
Label2(j).Top = 1300 + Topy * j
Label2(j).Caption = Data1.Recordset!RAINSTATNM
Label2(j).Visible = True
Next j
For j = 10 To Imax - 1
Load Slider1(j)
Slider1(j).Left = 7000
Slider1(j).Top = 1200 + Topy * (j - 10)
Slider1(j).Visible = True
Load Text1(j)
Text1(j).Left = 10200
Text1(j).Top = 1200 + Topy * (j - 10)
Text1(j).Visible = True
Data1.Recordset.MoveNext
Load Label2(j)
Label2(j).Left = 6240
Label2(j).Top = 1300 + Topy * (j - 10)
Label2(j).Caption = Data1.Recordset!RAINSTATNM
Label2(j).Visible = True
Next j
Command2.Left = 4400
Command2.Top = 2500 + Topy * 9
Command1.Left = 6300
Command1.Top = 2500 + Topy * 9
End If
For j = 0 To Imax - 1
Slider1(j).Max = Smax
Next
Stemp = Int(Smax / Imax)
For j = 0 To Imax - 2
Text1(j) = Stemp
Slider1(j).Value = Stemp
Next
Text1(Imax - 1) = Smax - Stemp * (Imax - 1)
Slider1(Imax - 1) = Smax - Stemp * (Imax - 1)
Else
If Imax < 2 Then
MsgBox "测站数为" & Imax & "，不能设定权重。"
Else '>20
MsgBox "测站数为" & Imax & "，超出程序设置范围，不能设定权重。"
End If
Command2.Enabled = False
Slider1(0).Visible = False
Label2(0).Visible = False
Text1(0).Visible = False
End If
End Sub
Private Sub Slider1_Click(Ix As Integer)
Dim j, S0
Dim Stemp
Dim Sx
S0 = Text1(Ix)
If Imax - Ix < 2 Then
MsgBox "不能改变！"
Slider1(Ix).Value = S0
Exit Sub
End If
Sx = 0
If Ix > 0 Then
For j = 0 To Ix - 1
Sx = Sx + Text1(j)
Next j
End If
Text1(Ix) = Slider1(Ix).Value
If Smax - Sx < Int(Text1(Ix)) Then
MsgBox "超出范围！"
Text1(Ix) = S0
Slider1(Ix) = S0
Else
Stemp = Int((Smax - Sx - Int(Text1(Ix))) / (Imax - 1 - Ix))
MsgBox "stemp=" & Stemp
If Imax - Ix = 0 Then
Text1(Imax - 1) = Stemp
Slider1(Imax - 1).Value = Stemp
Else
For j = Ix + 1 To Imax - 2
Text1(j) = Stemp
Slider1(j) = Stemp
Next j
Text1(Imax - 1) = (Smax - Sx - Int(Text1(Ix))) - Stemp * (Imax - Ix - 2)
Slider1(Imax - 1) = (Smax - Sx - Int(Text1(Ix))) - Stemp * (Imax - Ix - 2)
End If
End If
End Sub
用MSCHART产生图表
在【部件】中使用：
1． MS ADO Data Control 6.0;
2． MS Chart Control 6.0;
3． MS Datalist Control 6.0;
然后建立List(Liststation)、MSChart(ChartDemo)、Combo(ComboYear,ComboChartType)、Label1～Label4，程序为：
Option Explicit
Public iChartType As Integer '当前图表类型
Public cnn As ADODB.Connection
'双击数据点可以更改数据，并反馈到图形上
Private Sub ChartDemo_PointActivated(Series As Integer, DataPoint As Integer, MouseFlags As Integer, Cancel As Integer)
Dim vtPoint
With ChartDemo
.Column = Series
.Row = DataPoint
vtPoint = InputBox("更改数据点:", , .Data)
If vtPoint <> "" Then
If IsNumeric(vtPoint) Then
.Data = vtPoint
Else
MsgBox "没有有效的数据点!"
End If
End If
End With
End Sub
'单击数据点在Label4上反映该点的值
Private Sub ChartDemo_PointSelected(Series As Integer, DataPoint As Integer, MouseFlags As Integer, Cancel As Integer)
' 允许用户在序列中通过选择特别的数据点来查阅它的值。
' 数据点的值被显示在名为 lblDatapoint 的标签中。
ChartDemo.Column = Series
ChartDemo.Row = DataPoint
Label4.Caption = "序列的值 " & Series & ", 点 " & DataPoint & " = " & ChartDemo.Data
End Sub
'选择图形类型
Private Sub ComboChartType_click()
Dim i As Integer
Dim strType As String
strType = ComboChartType.Text
Select Case strType
Case "饼图"
iChartType = 14
Case "折线图"
iChartType = 3
Case "立体图"
iChartType = 0
Case "柱状图"
iChartType = 9
End Select
ChartDemo.chartType = iChartType
ComboYear_click
End Sub
'选择年份
Private Sub ComboYear_click()
Dim strYear, strStation As String
Dim i As Integer
Dim arrChartData()
Dim strSql As String
Dim rstChartData As New ADODB.Recordset
strYear = ComboYear.Text
If strYear = "" Then
Exit Sub
End If
ChartDemo.Visible = True
strStation = Liststation.Text
strSql = "select * from addvdata where addvcd='" _
& strStation & "' and year=" & strYear
rstChartData.Open strSql, cnn ', adOpenDynamic, adLockOptimistic
If iChartType = 3 Then
ReDim arrChartData(1 To 12, 1 To 1)
For i = 1 To 12
arrChartData(i, 1) = rstChartData.Fields(i + 1)
Next i
With ChartDemo
.ChartData = arrChartData
.RowCount = 12
.ColumnLabelCount = 12
For i = 1 To 12
.Row = i
.RowLabel = rstChartData.Fields(i + 1).Name
Next i
.ColumnCount = 1
.Column = 1
.ColumnLabel = ""
.Refresh
End With
Else
ReDim arrChartData(1 To 1, 1 To 12)
For i = 1 To 12
arrChartData(1, i) = rstChartData.Fields(i + 1)
Next i
With ChartDemo
.ChartData = arrChartData
.ColumnCount = 12
.ColumnLabelCount = 12
For i = 1 To 12
.Column = i
.ColumnLabel = rstChartData.Fields(i + 1).Name
Next i
.RowCount = 1
.Row = 1
.RowLabel = ""
.Refresh
End With
End If
rstChartData.Close
strSql = ""
End Sub
Private Sub Form_Load()
Dim rst1 As New ADODB.Recordset
Set cnn = New ADODB.Connection
cnn.Open "Provider=MSDASQL.1;Persist Security Info=False;Data Source=Demo"
If Err Then
MsgBox "数据库打开失败", vbOKOnly, "提示"
End
End If
ComboChartType.AddItem "饼图"
ComboChartType.AddItem "折线图"
ComboChartType.AddItem "立体图"
ComboChartType.AddItem "柱状图"
rst1.Open "select * from addvdata ", cnn
Do While Not rst1.EOF
Liststation.AddItem rst1!addvcd
rst1.MoveNext
Loop
rst1.Close
ChartDemo.Refresh
End Sub
'测站代码列表
Private Sub ListStation_Click()
Dim strScode As String
Dim rstYear As New ADODB.Recordset
strScode = Liststation.Text
If strScode = "" Then
Exit Sub
End If
ComboYear.Clear
rstYear.Open "select distinct year from addvdata where addvcd='" + strScode + "'", cnn ', adOpenDynamic, adLockOptimistic
Do While Not rstYear.EOF
ComboYear.AddItem rstYear.Fields("year")
rstYear.MoveNext
Loop
rstYear.Close
End Sub
用剪贴板向WORD中添加图形和文字
建立一个COMMAND1和一个PICTURE1，在PICTURE1中添加一幅图。
Option Explicit
Dim objWord As Object
Private Sub Command1_Click()
Const CLASSOBJECT = "Word.Application"
On Error GoTo objError
Set objWord = CreateObject(CLASSOBJECT)
objWord.Visible = True
objWord.Documents.Add
With objWord
.ActiveDocument.paragraphs.Last.Range.Bold = False
.ActiveDocument.paragraphs.Last.Range.Font.Size = 14
.ActiveDocument.paragraphs.Last.Range.Font.Name = "黑体"
.ActiveDocument.paragraphs.Last.Range.Font.colorindex = 0
'.ActiveDocument.paragraphs.Last.Range.Text = Chr(13) & "向WORD中传递数据和图形练习"
End With
Clipboard.Clear
Clipboard.SetData Picture1.Picture
objWord.Selection.Paste
Clipboard.Clear
Clipboard.SetText "通过剪帖板向WORD传递字符"
objWord.Selection.Paste
objWord.PrintPreview = True '打印预览
'objWord.PrintOut '打印
'objWord.Quit '结束Word
Exit Sub
objError:
If Err <> 429 Then
MsgBox Str$(Err) & Error$
Set objWord = Nothing
Exit Sub
Else
Resume Next
End If
End Sub
在WORD中产生表格和文字
Private Sub Command3_Click()
Dim objWord As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True '取消此行最后加上.Quit在后台运行
objWord.Documents.Add '可以加上路径，打开指定文件
With objWord
.Selection.Font.Name = "黑体"
.Selection.Font.Size = 14
.Selection.Font.Bold = True
.Selection.TypeText Text:="xuewei"
.Selection.Font.Name = "宋体"
.Selection.Font.Size = 10.5
.Selection.Font.Bold = False
.Selection.TypeParagraph '换行
'产生一个2行5列的表格
.ActiveDocument.Tables.Add Range:=.Selection.Range, NumRows:=2, NumColumns:=5
.Selection.TypeText Text:="12"
.Selection.MoveRight '向右移动光标，移到最后一个后自动到下行的第一个
.Selection.TypeText Text:="34"
.Selection.MoveDown '向下移动光标
.Selection.TypeText Text:="56"
.Selection.MoveDown
.Selection.TypeParagraph
.Selection.TypeText Text:="end"
.Selection.TypeParagraph
End With
End Sub
向WORD中传送SELECT表和CHART控件图形
添加PictureBox控件PicGraph，运行时先使Chart1控件有图形，然后点击Command3。
Private Sub Command3_Click()
Dim intWinState As Integer
Dim objWord As Object
Dim sql, i
Dim str1 As String
Dim Rows1, Columns1
On Error GoTo objError
Set objWord = CreateObject("Word.Application")
With objWord
.Visible = True
.Documents.Add '"c:\My Document\test1.doc"
.Selection.TypeText Text:="表标题"
.Selection.TypeParagraph
.Selection.TypeParagraph
.Selection.MoveUp , Count:=2
.Selection.Style = .ActiveDocument.Styles("标题 1")
.Selection.ParagraphFormat.Alignment = 1
.Selection.MoveDown
.Selection.TypeText Text:="插入表"
.Selection.TypeParagraph
End With
sql = "select * from hydnet"
rst0.Open sql, cnn
i = 0
While Not rst0.EOF
i = i + 1
rst0.MoveNext
Wend
Rows1 = i
Columns1 = rst0.Fields.Count
If i > 0 Then
objWord.ActiveDocument.Tables.Add Range:=objWord.Selection.Range, NumRows:=Rows1, NumColumns:=Columns1
rst0.MoveFirst
While Not rst0.EOF
For i = 0 To rst0.Fields.Count - 1
str1 = rst0.Fields(i)
objWord.Selection.TypeText Text:=str1
objWord.Selection.MoveRight
Next i
rst0.MoveNext
Wend
End If
