Visual Studio是微软公司推出的开发环境，是最流行的Windows平台应用程序开发环境。
中文汉化版
创建项目和使用技巧
创建项目
保存项目
Me.Text = "给窗口标题赋值"
异步操作案例
界面居中显示
' 设置窗口居中显示
Me.StartPosition = FormStartPosition.CenterScreen
Public Class Form1
Delegate Sub wt(ByVal action As String, ByVal msg As String)
Dim t As Threading.Thread '定义线程类
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Me.Text = "给窗口标题赋值"
End Sub
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
t = New Threading.Thread(AddressOf handleCaiYiBu) '让线程类指向子程序
t.Start(100000) '启动线程
End Sub
Sub handleCaiYiBu(ByVal nForCount)
Dim i
For i = 1 To nForCount
Me.Invoke(New wt(AddressOf callYiBuEcho), "动作", "循环=" & i)
Next
End Sub
'异步回显提示
Sub callYiBuEcho(ByVal action, ByVal msg)
Label1.Text = action & "=" & msg
End Sub
End Class
Public Class Form1
Delegate Sub wt(ByVal action As String, ByVal msg As String)
Dim t As Threading.Thread '定义线程类
Dim shouldStop As Boolean = False '添加停止标志
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Me.Text = "给窗口标题赋值"
End Sub
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
shouldStop = False '重置停止标志
Button1.Enabled = False '禁用开始按钮
Button2.Enabled = True '启用停止按钮
t = New Threading.Thread(AddressOf handleCaiYiBu) '让线程类指向子程序
t.Start(100000) '启动线程
End Sub
Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
If t IsNot Nothing AndAlso t.IsAlive Then
shouldStop = True '设置停止标志
t.Join(1000) '等待线程结束
Button1.Enabled = True '重新启用开始按钮
Button2.Enabled = False '禁用停止按钮
Label1.Text = "已停止"
End If
End Sub
Sub handleCaiYiBu(ByVal nForCount)
Dim i
For i = 1 To nForCount
If shouldStop Then
Exit For '检查停止标志
End If
Me.Invoke(New wt(AddressOf callYiBuEcho), "动作", "循环=" & i)
Threading.Thread.Sleep(100) '添加小延迟使效果更明显
Next
'循环结束后重置按钮状态
Me.Invoke(Sub()
Button1.Enabled = True
Button2.Enabled = False
End Sub)
End Sub
'异步回显提示
Sub callYiBuEcho(ByVal action, ByVal msg)
Label1.Text = action & "=" & msg
End Sub
End Class
Public Class test001
Delegate Sub wt(ByVal msg As String)
Delegate Sub wt2(ByVal content, ByVal sType)
Dim t As Threading.Thread '定义线程类
Dim action = "" '异步动作
Dim httpUrl = "" '网址
Dim webContent = "" '网页内容
'加载
Private Sub test001_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
End Sub
'点击
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
Call yibu("http://xiyueta.com/")
End Sub
'异步操作
Sub yibu(ByVal url)
httpUrl = url
t = New Threading.Thread(AddressOf yibuAction) '让线程类指向子程序
t.Start() '启动线程
End Sub
'操作异步动作
Sub yibuAction()
If action = "初始化" Then
Me.Invoke(New wt(AddressOf waibuSub1), "初始化")
Else
webContent = getHttpUrl(httpUrl, "utf-8")
Me.Invoke(New wt(AddressOf waibuSub1), "其它" & webContent)
End If
End Sub
'异步完成 ********************************************
Private Sub waibuSub1(ByVal msg)
If msg <> "" Then
txtMsg.Text += msg & vbCrLf
End If
End Sub
'判断是否为空
Function isNul(ByVal s)
On Error Resume Next : If Err.Number <> 0 Then Err.Clear()
isNul = False
Select Case VarType(s)
Case vbEmpty, vbNull
isNul = True : Exit Function
Case vbString
If s = "" Then isNul = True : Exit Function
Case vbObject
Select Case TypeName(s)
Case "Nothing", "Empty"
isNul = True : Exit Function
Case "Recordset"
If s.State = 0 Then isNul = True : Exit Function
If s.BOF And s.EOF Then isNul = True : Exit Function
Case "Dictionary"
If s.Count = 0 Then isNul = True : Exit Function
End Select
Case vbArray, 8194, 8204, 8209
If UBound(s) = -1 Then isNul = True : Exit Function
End Select
On Error GoTo 0
End Function
'处理字符编码 20150723
Function handleStrCharSet(ByRef sSetChar As String)
If sSetChar = "1" Or UCase(sSetChar) = "GB2312" Or sSetChar = "" Then
sSetChar = "GB2312"
ElseIf sSetChar = "0" Or UCase(sSetChar) = "UTF-8" Then
sSetChar = "UTF-8"
ElseIf sSetChar = "2" Or UCase(sSetChar) = "UNICODE" Then
sSetChar = "UNICODE"
End If
handleStrCharSet = sSetChar
End Function
'正则表达式获得字符长度 中文二个字符
Function strLength(ByRef str As String)
Dim rep, lens, i
lens = 0
rep = CreateObject("VBscript.RegExp")
rep.global = True
rep.ignoreCase = True
rep.pattern = "[\u4E00-\u9FA5\uF900-\uFA2D]"
For Each i In rep.Execute(str)
lens = lens + 1
Next
rep = Nothing
lens = lens + Len(str)
strLength = lens
End Function
'获得采集内容 (辅助)
Function getHttpUrl(ByRef httpurl As String, ByRef sCharSet As String)
getHttpUrl = handleGetHttpPage(httpurl, sCharSet)(0)
End Function
Function bytesToBstr(ByRef byteArr() As Byte, ByRef cset As String)
Dim objStream
If isNul(byteArr) Then Exit Function '为空则退出
objStream = CreateObject("ADODB.Stream")
objStream.Type = 1
objStream.Mode = 3
objStream.Open()
Call objStream.Write(byteArr)
objStream.position = 0
objStream.Type = 2
objStream.Charset = cset
bytesToBstr = objStream.readText
objStream.Close()
objStream = Nothing
End Function
'处理获得采集内容
Function handleGetHttpPage(ByVal httpurl As String, ByVal sCharSet As String)
On Error Resume Next
Dim startTime, nStatus, nTime, content, sSplType, webFileSize
startTime = Now()
sSplType = "|-*ypia=|"
sCharSet = handleStrCharSet(sCharSet)
If isNul(httpurl) = True Or Len(httpurl) < 7 Or httpurl = "$False$" Then
handleGetHttpPage = Split("" & sSplType & -1 & sSplType & nTime & sSplType & webFileSize, sSplType)
Exit Function
End If
Dim http
http = CreateObject("MSXML2.XMLHTTP")
Call http.Open("GET", httpurl, False)
http.send()
If http.readyState <> 4 Then
http = Nothing
handleGetHttpPage = Split("" & sSplType & http.readyState & sSplType & nTime & sSplType & webFileSize, sSplType)
Exit Function
End If
content = bytesToBstr(http.responseBody, sCharSet)
nStatus = http.Status
nTime = DateDiff("s", startTime, Now())
webFileSize = strLength(content)
handleGetHttpPage = Split(content & sSplType & nStatus & sSplType & nTime & sSplType & webFileSize, sSplType)
http = Nothing
End Function
End Class
加载Microsoft Script Control 1.0
Imports MSScriptControl
Public Class Form1
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
Dim sc
sc = CreateObject("ScriptControl")
sc.language = "Jscript" '设置语言为javascript
sc.Timeout = -1
sc.AddCode(getFText("asp.xiyueta.min.js"))
sc.AddCode(getFText("1.js"))
Dim txtHtml = "<div>aaa</div><div>bbb</div><div>ccc</div>"
'两种调用方法
'Sc.Run("mytestfun", html)
Dim s = sc.Eval(" xiyueta.load('" & txtHtml & "');;xiyueta('div').text()")
MsgBox(s)
s = sc.Eval("xiyueta('div:eq(0)').text()")
MsgBox(s)
Call sc.Run("load", txtHtml)
End Sub
'读文件内容 (2013,9,27
Function getFText(ByVal filePath As String)
Dim fso, fText, openFile
getFText = "" '它默认返回的就是空， 这个是多此一举 (2013,9,30)
filePath = Application.StartupPath() & "/" & filePath
'获得完整路径
fso = CreateObject("Scripting.FileSystemObject")
If fso.fileExists(filePath) = True Then
fText = fso.openTextFile(filePath, 1)
'加强 读空文件出错
openFile = fso.getFile(filePath)
If openFile.Size = 0 Then getFText = "" : Exit Function '文件为空则退出
openFile = Nothing
getFText = fText.readAll
fText = Nothing
End If
fso = Nothing
End Function
End Class
加载Microsoft Script Control 1.0
