加密文件
本例介绍如何加密文件。
Private Sub CodedFile(InputFile As String, OutputFile As String, PasswordKey As Integer)
Dim Char As String * 1
'打开要加密/解密的文件
Open InputFile For Binary As #1
'打开加密/解密后生成的文件
Open OutputFile For Binary As #2
For z = 1 To FileLen(InputFile)
'读取文件中的字符
Get 1, , Char
'与密钥进行异或运算
Char = Chr$((Asc(Char) Xor PasswordKey))
'将运算结果写入文件
Put 2, , Char
Next z
'关闭文件
Close #1
Close #2
End Sub
Private Sub Command1_Click()
Dim InputFile As String
Dim OutputFile As String
Dim PasswordKey As Integer
InputFile = InputBox("输入要加密/解密的文件名", "加密/解密")
OutputFile = InputBox("输入加密/解密后的文件名", "加密 / 解密到")
PasswordKey = InputBox("输入密钥（整数）", "输入密钥")
Call CodedFile(InputFile, OutputFile, PasswordKey)
MsgBox "文件已加密/解密到： " + OutputFile, , "完成"
End
End Sub 作者: winggd 时间: 2004-3-22 11:13 标题: vb学习3
从Excel中读取数据到数据库
本程序可以从Excel中读取数据到Access数据库中。
Option Explicit
Private Sub cmdLoad_Click()
Dim excel_app As Object
Dim excel_sheet As Object
Dim db As Database
Dim new_value As String
Dim row As Integer
Screen.MousePointer = vbHourglass
DoEvents
'建立Excel application对象
Set excel_app = CreateObject("Excel.Application")
'打开指定的工作薄
excel_app.Workbooks.Open FileName:=txtExcelFile.Text
'判断版本
If Val(excel_app.Application.Version) >= 8 Then
Set excel_sheet = excel_app.ActiveSheet
Else
Set excel_sheet = excel_app
End If
'打开Access数据库
Set db = OpenDatabase(txtAccessFile.Text)
'删除表中原有记录
db.Execute "delete from TestValues"
' 从Excel工作表中获取数据并插入到数据库的TestValues表中
row = 1
Do
' 得到工作表中的值
new_value = Trim$(excel_sheet.Cells(row, 1))
'如果某行空，则停止
If Len(new_value) = 0 Then Exit Do
'将获取的值插入到数据库的表TestValues中
db.Execute "INSERT INTO TestValues VALUES (" & new_value & ")"
'下一行
row = row + 1
Loop
' 关闭数据库
db.Close
'释放内存
Set db = Nothing
'关闭工作表，不重新保存
excel_app.ActiveWorkbook.Close False
'关闭Excel
excel_app.Quit
'释放内存
Set excel_sheet = Nothing
Set excel_app = Nothing
'鼠标指针形状还原
Screen.MousePointer = vbDefault
'弹出提示框
MsgBox "Copied " & Format$(row - 1) & " values.", , "Finished"
End Sub
Private Sub Form_Load()
'初始化文件路径
Dim file_path As String
file_path = App.Path
If Right$(file_path, 1) <> "\" Then file_path = file_path & "\"
txtExcelFile.Text = file_path & "XlsToMdb.xls"
txtAccessFile.Text = file_path & "XlsToMdb.mdb"
End Sub
作者: winggd 时间: 2004-3-22 11:13 标题: vb学习3
使用MMControl控件播放媒体文件
本例设计了一个多媒体播放器，它能够播放WAV、MIDI和AVI文件。
Private Sub Check2_Click()
If Check2.Value = 1 Then
'关闭AVI文件的声音
MMControl1.Silent = True
Else
'打开AVI文件的声音
MMControl1.Silent = False
End If
End Sub
Private Sub ComClose_Click()
MMControl1.Command = "close"
End Sub
Private Sub ComPlay_Click()
MMControl1.Command = "close"
DiaOpen.Filter = "Wav文件|*.wav|MIDI文件|*.mid|AVI文件|*.avi"
DiaOpen.ShowOpen
MMControl1.FileName = DiaOpen.FileName
MMControl1.Command = "open"
MMControl1.Command = "play"
LabFile.Caption = DiaOpen.FileName
End Sub
Private Sub Form_Load()
'初始化
MMControl1.Visible = False
MMControl1.Notify = True
MMControl1.Shareable = False
MMControl1.TimeFormat = 0
End Sub
Private Sub Form_Unload(Cancel As Integer)
MMControl1.Command = "close"
End Sub
Private Sub MMControl1_StatusUpdate()
'计算文件总长度，单位为秒
LabLen.Caption = MMControl1.Length / 1000
'动态显示当前的播放位置
LabPlay.Caption = MMControl1.Position / 1000
End Sub
Private Sub MMControl1_Done(NotifyCode As Integer)
'如果文件播放结束
If MMControl1.Position = MMControl1.Length Then
'倒回止文件的起点
MMControl1.Command = "prev"
'如果选择了自动重复播放
If Check1.Value = 1 Then
MMControl1.Command = "play"
End If
End If
End Sub作者: winggd 时间: 2004-3-22 11:14 标题: vb学习3
制作自己的浏览器
本例介绍如何使用VB来编写一个自己的浏览器。
'初始化
Private Sub Form_Load()
ComSite.AddItem "清华大学"
ComSite.AddItem "首都在线"
ComSite.AddItem "中央电视台"
ComSite.AddItem "网易"
ComSite.AddItem "搜狐"
ComSite.Text = "清华大学"
'链接到主页
WebBrowser1.GoHome
End Sub
'设置各控件的位置
Private Sub Form_Resize()
If Form1.WindowState = 1 Then
Exit Sub
End If
WebBrowser1.Left = 200
WebBrowser1.Top = 900
WebBrowser1.Width = Form1.ScaleWidth - 400
WebBrowser1.Height = Form1.ScaleHeight - 1500
ProgressBar1.Top = Form1.ScaleHeight - 300
ProgressBar1.Left = Form1.ScaleWidth - 2200
End Sub
'链接到主页
Private Sub Comhome_Click()
WebBrowser1.GoHome
End Sub
'后退
Private Sub Comback_Click()
On Error GoTo ww
WebBrowser1.GoBack
Exit Sub
ww:
MsgBox "没有历史记录", 64, "提示"
End Sub
'前进
Private Sub ComForward_Click()
On Error GoTo ww
WebBrowser1.GoForward
Exit Sub
ww:
MsgBox "没有历史记录", 64, "提示"
End Sub
'选择网址
Private Sub ComSite_Click()
Select Case ComSite.Text
Case "清华大学"
WebBrowser1.Navigate "http://www.tsinghua.edu.cn" '链接到清华大学主页
Case "首都在线"
WebBrowser1.Navigate "http://www.263.net" '链接到清华大学主页
Case "中央电视台"
WebBrowser1.Navigate "http://www.cctv.com" '链接到清华大学主页
Case "网易"
WebBrowser1.Navigate "http://www.163.com" '链接到清华大学主页
Case "搜狐"
WebBrowser1.Navigate "http://www.sohu.com" '链接到清华大学主页
Case Else
'链接到其他
WebBrowser1.Navigate ComSite.Text
End Select
End Sub
'在地址栏输入地址
Private Sub ComSite_KeyDown(KeyCode As Integer, Shift As Integer)
Dim i As Long
Dim existed As Boolean
'当按下回车键
If KeyCode = 13 Then
If Left(ComSite.Text, 7) <> "http://" Then
ComSite.Text = "http://" + ComSite.Text
End If
WebBrowser1.Navigate ComSite.Text
For i = 0 To ComSite.ListCount - 1
If ComSite.List(i) = ComSite.Text Then
existed = True
Exit For
Else
existed = False
End If
Next
If Not existed Then
ComSite.AddItem (ComSite.Text)
End If
End If
End Sub
'web页的标题变化
Private Sub WebBrowser1_TitleChange(ByVal Text As String)
'在窗体标题栏上显示web页的标题
Form1.Caption = WebBrowser1.LocationURL
'在地址栏中显示web页的标题
ComSite.Text = WebBrowser1.LocationURL
End Sub
'开始下载
Private Sub WebBrowser1_DownloadBegin()
'状态栏显示“Now Linking...”
StatusBar1.SimpleText = "Now Linking..."
End Sub
'下载完成
Private Sub WebBrowser1_DownloadComplete()
'状态栏显示Link Finished
StatusBar1.SimpleText = "Link Finished"
'清除进度条
ProgressBar1.Value = 0
End Sub
'下载过程
Private Sub WebBrowser1_ProgressChange(ByVal Progress As Long, ByVal ProgressMax As Long)
'下载进行时进度条变化
If ProgressMax = 0 Then Exit Sub
ProgressBar1.Max = ProgressMax
If Progress <> -1 And Progress <= ProgressMax Then
ProgressBar1.Value = Progress
End If
End Sub
