Option Explicit
Private Sub Command1_Click()
Me.Cls
Print Now; "开始读取数据"
DoEvents
Call AP60First
Print Now; "读取数据完成，共计："; RowCount; "行数据"
Print Now; "开始启动双线程运算"
DoEvents
'启动双线程
'
线程函数
创建后立即运行
VBThreadHandle1 = CreateThread(ByVal 0&, ByVal 0&, AddressOf VBMTRun.Thread1, ByVal 0&, ByVal CREATE_DEFAULT, VBThreadID1)
VBThreadHandle2 = CreateThread(ByVal 0&, ByVal 0&, AddressOf VBMTRun.Thread2, ByVal 0&, ByVal CREATE_DEFAULT, VBThreadID2)
DoEvents
'VB6主线程一边傻等子线程全部结束一边睡大觉
Do Until (Thread1exit = 1 And Thread2exit = 1)
DoEvents
'刷新界面，防止窗口卡顿
Sleep 30
'睡大觉
Loop
Print Now; "运算完成，开始写结果"
DoEvents
Dim filePath As String
filePath = "d:\2.txt"
StrLine2 = Left(StrLine2, Len(StrLine2) - 1)
'去除该行字符串的结尾的逗号
Open filePath For Output As #1
Print #1, StrLine1; StrLine2 '写入文本文件
Close #1
Print Now; "写结果完成"
End Sub
Sub AP60First()
Const CON_RECORD_COUNT As Long = 5000000
Dim filePath As String
filePath = "d:\1.txt"
Dim i As Long, j As Long, d As Single
ReDim X(1 To CON_RECORD_COUNT), Y(1 To CON_RECORD_COUNT), G(1 To CON_RECORD_COUNT)
'从txt加载到数组
Dim textSplit
Dim doCount As Long
doCount = 1
Dim rowText As String
Open filePath For Input As #1
Do While Not EOF(1)
Line Input #1, rowText
If doCount >= 2 Then
textSplit = VBA.Split(rowText, ",")
X(doCount - 1) = textSplit(0)
'第一个数据导入
Y(doCount - 1) = textSplit(1)
'第二个数据导入
G(doCount - 1) = textSplit(2)
'第三个数据导入
End If
doCount = doCount + 1
Loop
Close #1
RowCount = doCount - 2
End Sub
-------VBMTRun-------------
Option Explicit
'定义线程句柄
Public VBThreadHandle1 As Long, VBThreadHandle2 As Long
'定义线程ID
Public VBThreadID1 As Long, VBThreadID2 As Long
'定义线程退出变量
Public Thread1exit As Long, Thread2exit As Long
Public RowCount As Long
Public X() As Single, Y() As Single, G() As Long
Public StrLine1 As String, StrLine2 As String
'************************************注意：VB6多线程必须以SUB MAIN为启动对象***************************************************
'***************************本示例中已经设置好了，自己使用时注意在工程——属性——启动对象中自行选择************************
Sub Main()
If AvoidReentrant = False Then
'防止主线程重复运行
AvoidReentrant = True
If App.PrevInstance Then
'防止程序重复运行
MessageBox ByVal 0&, StrPtr("程序正在运行或未完全退出"), StrPtr("重复运行"), vbCritical
Exit Sub
Else
InitCommonControls
'初始化通用控件
GETVBHeader
'获取VB数据头
Form1.Show
'在这里加载主窗体
End If
End If
End Sub
Public Sub Thread1()
'子线程1
'***********************************（重要！）VB6线程环境初始化*************************************************
CreateIExprSrvObj 0&, 4&, 0&
'VB6运行库初始化
CoInitializeEx ByVal 0&, ByVal (COINIT_MULTITHREADED Or COINIT_SPEED_OVER_MEMORY)
'COM组件初始化
InitVBdll
'诱导VB6运行库内部其他部分的初始化
'***********************************（重要！）VB6线程环境初始化*************************************************
Thread1exit = 0
Dim i As Long
Dim j As Long, d As Long
For i = 1 To RowCount / 2
'这里有误差，这里只是测试一下
If G(i) > 0 Then
For j = 1 To RowCount
d = (X(i) - X(j)) ^ 2 + (Y(i) - Y(j)) ^ 2
StrLine1 = StrLine1 & d & ","
'将计算结果组合成字符串，以逗号分隔
Next
End If
Next i
Thread1exit = 1
CoUninitialize
'卸载COM组件（省掉也不会影响稳定性，但可能造成句柄或内存泄漏。为了养成好习惯，还是写上）
End Sub
Public Sub Thread2()
'子线程2
'***********************************（重要！）VB6线程环境初始化*************************************************
CreateIExprSrvObj 0&, 4&, 0&
'VB6运行库初始化
CoInitializeEx ByVal 0&, ByVal (COINIT_MULTITHREADED Or COINIT_SPEED_OVER_MEMORY)
'COM组件初始化
InitVBdll
'诱导VB6运行库内部其他部分的初始化
'***********************************（重要！）VB6线程环境初始化*************************************************
Thread2exit = 0
Dim i As Long
Dim j As Long, d As Long
For i = RowCount / 2 + 1 To RowCount
'这里有误差，这里只是测试一下
If G(i) > 0 Then
For j = 1 To RowCount
d = (X(i) - X(j)) ^ 2 + (Y(i) - Y(j)) ^ 2
StrLine2 = StrLine2 & d & ","
'将计算结果组合成字符串，以逗号分隔
Next
End If
Next i
Thread2exit = 1
CoUninitialize
'卸载COM组件（省掉也不会影响稳定性，但可能造成句柄或内存泄漏。为了养成好习惯，还是写上）
End Sub
--------VBMTInit-----------
不贴了，自己找去。
VBA代码.rar
(1.09 KB)
