module1.bas

vb apriori algorithm

Attribute VB_Name = "Module1"
Public Declare Function GetCurrentTime Lib "kernel32" Alias "GetTickCount" () As Long
Public Declare Function SetEndOfFile Lib "kernel32" (ByVal hFile As Long) As Long
Public Declare Function GetTickCount Lib "kernel32" () As Long
Type ItemNode
ItemStr As String
ItemStrCount As Integer
End Type


''******************************************************************************
Global Gendata_rs As ADODB.Recordset
Global Gendata_cnn As ADODB.Connection

Global change_or_not As Integer   '判断工作状态是够发生改变
Global begin_time As Long         '状态改变开始的时间
Global change_time As String      '状态改变的时间
Global work_time As Long          '总的工作时间
Global non_work_time As Long      '总的非工作时间
Global work_status As Integer
Global work_status_new As Integer
Global work_status_old As Integer
Global end_time As Long
Global Sparetime As Long
Global mean, deviation As Single
Global normaldistribut(1 To 20) As Single        '正态分布中平均数=6 标准差=4 时1~20的分布频率
Global normaldistribut_TNum(1 To 20) As Integer   '（正态分布）含有1~20种商品的交易的数目
Global itemupperbound, itemlowerbound As Integer '所有交易品的数量
Global itemnum() As Integer    '每个交易的交易商品的数字表示
Global ItemString As String '每个交易的交易商品的品名字符串
Global ItemCount() As Integer
Global SupportThreshold, ConfidenceThreshold As Single
Global TotalTransNum As Integer
Global Temp() As ItemNode
Global L1(0 To 100) As ItemNode
Global C2() As ItemNode
Global L2() As ItemNode
Global L1Num, L2Num As Integer 'L1中元素个数 L1Num+1
Global ItemStr() As String   'StrDecompose Candidate字符串 中字符串分解后的字符数组 在SubSet中比较使用
Global C2TotalNum, C2Num As Integer

Global H2() As ItemNode
Public Sub main()
Dim NNum As Integer
NNmu = 100
itemupperbound = 100
itemlowerbound = 1
mean = 6
deviation = 4
SupportThreshold = 0.01
ConfidenceThreshold = 0.6
'For i = 1 To 100
    'ItemCount(i) = 0
'Next i
ReDim H2(0 To NNum * (NNum - 1) - 1)
NormalDistributing (1000)
TotalTransNum = 0
Dim i, j As Integer
For i = 1 To 20
    TotalTransNum = TotalTransNum + normaldistribut_TNum(i)
Next i
'normaldistribut_TNum(19) = 50
'normaldistribut_TNum(20) = 50
Frm_gendata.Enabled = True
Frm_gendata.Visible = True
End Sub
Public Function NormalDistributing(ByVal TransNum)
normaldistribut(1) = 0.1056
normaldistribut(2) = 0.0531
normaldistribut(3) = 0.0679
normaldistribut(4) = 0.0819
normaldistribut(5) = 0.0928
normaldistribut(6) = 0.0987
normaldistribut(7) = 0.0987
normaldistribut(8) = 0.0928
normaldistribut(9) = 0.0819
normaldistribut(10) = 0.0679
normaldistribut(11) = 0.0531
normaldistribut(12) = 0.0388
normaldistribut(13) = 0.0267
normaldistribut(14) = 0.0173
normaldistribut(15) = 0.0106
normaldistribut(16) = 0.006
normaldistribut(17) = 0.0032
normaldistribut(18) = 0.0017
normaldistribut(19) = 0.0007
normaldistribut(20) = 0.0007
Dim i, j As Integer
For i = 1 To 20
    normaldistribut_TNum(i) = Int(normaldistribut(i) * TransNum)
Next i

End Function
Sub QuickSort(MyArray() As Integer, l, R)
Dim i, j, x, Y

    i = l
    j = R
    x = MyArray((l + R) / 2)
        
    While (i <= j)
        While (MyArray(i) < x And i < R)
            i = i + 1
        Wend
        While (x < MyArray(j) And j > l)
            j = j - 1
        Wend
        If (i <= j) Then
            Y = MyArray(i)
            MyArray(i) = MyArray(j)
            MyArray(j) = Y
            i = i + 1
            j = j - 1
        End If
        gIterations = gIterations + 1
    Wend

    If (l < j) Then Call QuickSort(MyArray(), l, j)
    If (i < R) Then Call QuickSort(MyArray(), i, R)

End Sub
Public Function GenrndItem(upperbound As Integer)
Dim i, j, k, l, m As Integer
Dim a As Integer
ReDim ItemCount(0 To upperbound - 1)
itemupperbound = upperbound
itemlowerbound = 1
For i = 1 To 20
    'ReDim ItemNum(normaldistribut_TNum(i)) As Integer
    For j = 1 To normaldistribut_TNum(i)
        ReDim itemnum(1 To i)
        ItemString = ""
        For k = 1 To i
TestSame:   Randomize
            itemnum(k) = Int(itemupperbound - itemlowerbound + 1) * Rnd
            If itemnum(k) = itemupperbound Then
                GoTo TestSame
            Else
            End If
            If k = 1 Then
            Else
                For l = 1 To k - 1
                    If (itemnum(k) - itemnum(l)) = 0 Then
                        GoTo TestSame
                    Else
                    End If
                Next l
            End If
        Next k
        If i = 1 Then
        Else
            Call QuickSort(itemnum(), 1, UBound(itemnum))
        End If
        For m = 1 To i
            If itemnum(m) < 100 Then
                If itemnum(m) >= 10 Then
                    ItemString = ItemString + "I" + "0" + CStr(itemnum(m))
                Else
                    ItemString = ItemString + "I" + "00" + CStr(itemnum(m))
                End If
            Else
                ItemString = ItemString + "I" + CStr(itemnum(m))
            End If
        Next m
            Gendata_rs.AddNew
            Gendata_rs!item = ItemString
            Gendata_rs.Update
            Gendata_rs.MoveNext

    Next j
Next i
End Function
Public Function ConnectDMDB1000()
strCnn = "driver={SQL Server};server=YANLIANG;uid=;pwd=;database=Gendata"
'strCnn = "driver={SQL Server};server=HSC-NK5VRBZL47D;uid=;pwd=;database=Gendata"

Set Gendata_cnn = New ADODB.Connection
    Gendata_cnn.Open strCnn
    Dim a As Integer
    a = Gendata_cnn.Errors.count
    'If (a <> 0 And a <> 2) Then
    'MsgBox Gendata_cnn.Errors(a).Description
    'End If
Set Gendata_rs = New ADODB.Recordset
    Gendata_rs.CursorType = adOpenKeyset
    Gendata_rs.LockType = adLockOptimistic
    Gendata_rs.Open "y_t_Gendata1000_100", Gendata_cnn, , , adCmdTable
Dim i, b, upbound, lowbound As Integer
    If (Gendata_rs.BOF Or Gendata_rs.EOF) Then
    Else
        Gendata_rs.MoveLast
    End If
    'Gendata_rs.AddNew
    'Gendata_rs!item = 0
    'Gendata_rs.Update
End Function
Public Function ConnectDMDB10000()
strCnn = "driver={SQL Server};server=YANLIANG;uid=;pwd=;database=Gendata"
'strCnn = "driver={SQL Server};server=HSC-NK5VRBZL47D;uid=;pwd=;database=Gendata"

Set Gendata_cnn = New ADODB.Connection
    Gendata_cnn.Open strCnn
    Dim a As Integer
    a = Gendata_cnn.Errors.count
    'If (a <> 0 And a <> 2) Then
    'MsgBox Gendata_cnn.Errors(a).Description
    'End If
Set Gendata_rs = New ADODB.Recordset
    Gendata_rs.CursorType = adOpenKeyset
    Gendata_rs.LockType = adLockOptimistic
    Gendata_rs.Open "y_t_Gendata10000_1000", Gendata_cnn, , , adCmdTable
Dim i, b, upbound, lowbound As Integer
    If (Gendata_rs.BOF Or Gendata_rs.EOF) Then
    Else
        Gendata_rs.MoveLast
    End If
    'Gendata_rs.AddNew
    'Gendata_rs!item = 0
    'Gendata_rs.Update
End Function
Public Function ConnectDMDB100000()
strCnn = "driver={SQL Server};server=YANLIANG;uid=;pwd=;database=Gendata"
'strCnn = "driver={SQL Server};server=HSC-NK5VRBZL47D;uid=;pwd=;database=Gendata"

Set Gendata_cnn = New ADODB.Connection
    Gendata_cnn.Open strCnn
    Dim a As Integer
    a = Gendata_cnn.Errors.count
    'If (a <> 0 And a <> 2) Then
    'MsgBox Gendata_cnn.Errors(a).Description
    'End If
Set Gendata_rs = New ADODB.Recordset
    Gendata_rs.CursorType = adOpenKeyset
    Gendata_rs.LockType = adLockOptimistic
    Gendata_rs.Open "y_t_Gendata100000_1000", Gendata_cnn, , , adCmdTable
Dim i, b, upbound, lowbound As Integer
    If (Gendata_rs.BOF Or Gendata_rs.EOF) Then
    Else
        Gendata_rs.MoveLast
    End If
    'Gendata_rs.AddNew
    'Gendata_rs!item = 0
    'Gendata_rs.Update
End Function


Public Function ItemStringDecompose(ItemStr As String)
Dim mystring, mychar As String
Dim beginpos, endpos, pos, strlen, num As Integer
mychar = "I"
beginpos = 1 + 1
endpos = 1
mystring = ItemStr
strlen = Len(mystring)
Do While (InStr(beginpos, mystring, mychar, vbTextCompare))
    pos = InStr(beginpos, mystring, mychar, vbTextCompare)
    num = Val(Mid(mystring, beginpos, (pos - beginpos)))
    ItemCount(num) = ItemCount(num) + 1
    beginpos = pos + 1
Loop
    num = Val(Mid(mystring, beginpos, (strlen - beginpos)))
    ItemCount(num) = ItemCount(num) + 1
End Function
Public Function GenL1(itemnum As Integer)
L1Num = 1
For j = 0 To itemnum - 1
    If (ItemCount(j) / TotalTransNum) >= SupportThreshold Then
        L1(L1Num).ItemStr = "I" + CStr(j)
        L1(L1Num).ItemStrCount = ItemCount(j)
        L1Num = L1Num + 1
    Else
        
    End If
Next j
End Function
Public Function GenC2()
C2TotalNum = (L1Num - 1) * L1Num / 2 - 1
ReDim C2(0 To (C2TotalNum))
ReDim Temp(0 To (C2TotalNum))
C2Num = 0
''''''''''''此处需要改变一下 用L1Num 可以减少循环次数
For i = 0 To L1Num - 1
        For j = i + 1 To L1Num - 1
            C2(C2Num).ItemStr = L1(i).ItemStr + L1(j).ItemStr
            C2Num = C2Num + 1
        Next j
Next i

End Function
Public Function StrDecomposeOld(Str As String, n As Integer)
Dim mystring, mychar As String
Dim beginpos, endpos, pos, strlen, num As Integer
Dim INum As Integer
ReDim ItemStr(0 To n - 1)
mychar = "I"
beginpos = 1 + 1
endpos = 1
mystring = Str
strlen = Len(mystring)
INum = 0
Do While (InStr(beginpos, mystring, mychar, vbTextCompare))
    pos = InStr(beginpos, mystring, mychar, vbTextCompare)
    num = Val(Mid(mystring, beginpos, (pos - beginpos)))
    ItemStr(INum) = "I" + CStr(num)
    beginpos = pos + 1
    INum = INum + 1
Loop
    num = Val(Mid(mystring, beginpos))
    ItemStr(INum) = "I" + CStr(num)
End Function
Public Function StrDecompose(Str As String, n As Integer, itemnum As Integer)
Dim i, a, BeginPoint As Integer
ReDim ItemStr(0 To n - 1)
ReDim ItemCount(0 To itemnum - 1)
For i = 0 To n - 1
    BeginPoint = (i) * 4 + 2
    ItemStr(i) = Mid(Str, BeginPoint, 3)
    a = Val(ItemStr(i))
    ItemCount(a) = ItemCount(a) + 1
Next i
End Function
Public Function SubSet(Str1 As String, Str2 As String, C2Turn As Integer)
StrDecompose Str2, 2
'C2Turn = 34
Dim i As Integer
Dim pos As Integer
For i = 0 To 1
    If InStr(1, Str1, ItemStr(i), vbTextCompare) Then
        pos = InStr(1, Str1, ItemStr(i), vbTextCompare)
        If (Mid(Str1, pos + Len(ItemStr(i)), 1) = "I" Or Mid(Str1, pos + Len(ItemStr(i)), 1) = "") Then
            If i = 1 Then
                C2(C2Turn).ItemStrCount = C2(C2Turn).ItemStrCount + 1
            Else
            End If
        Else
        End If
    Else
        Exit Function
    End If
Next i
End Function
Public Function JudgeLargeItemSet()
L2Num = 0
For i = 0 To C2TotalNum
    If (C2(i).ItemStrCount / TotalTransNum) >= SupportThreshold Then
        Temp(L2Num).ItemStr = C2(i).ItemStr
        Temp(L2Num).ItemStrCount = C2(i).ItemStrCount
        L2Num = L2Num + 1
    Else
        'L1(j) = ""
    End If
Next i
ReDim L2(0 To L2Num - 1)
For j = 0 To L2Num - 1
    L2(j).ItemStr = Temp(j).ItemStr
    L2(j).ItemStrCount = Temp(j).ItemStrCount
Next j

End Function
Public Function GenrndItem1920()
Dim i, j, k, l, m As Integer
Dim a As Integer
itemupperbound = 100
itemlowerbound = 1
normaldistribut_TNum(19) = 50
normaldistribut_TNum(20) = 50
Gendata_rs.MoveLast
For i = 19 To 20
    'ReDim ItemNum(normaldistribut_TNum(i)) As Integer
    For j = 1 To normaldistribut_TNum(i)
        ReDim itemnum(1 To 2)
        ItemString = ""
        For k = 1 To 2
TestSame:   Randomize
            itemnum(k) = Int(itemupperbound - itemlowerbound + 1) * Rnd
            If k = 1 Then
            Else
                For l = 1 To k - 1
                    If (itemnum(k) - itemnum(l)) = 0 Then
                        GoTo TestSame
                    Else
                    End If
                Next l
            End If
        Next k
        If i = 1 Then
        Else
            Call QuickSort(itemnum(), 1, UBound(itemnum))
        End If
        For m = 1 To 2
            ItemString = ItemString + "I" + CStr(itemnum(m))
        Next m
            Gendata_rs.AddNew
            Gendata_rs!item = ItemString
            Gendata_rs.Update
            Gendata_rs.MoveNext

    Next j
Next i
End Function
Public Function RndGenItem(AddNum As Integer, itemupperbound As Integer)
Dim i, j, k, l, m As Integer
Dim a As Integer
    For j = 1 To AddNum
        ReDim itemnum(1 To 40)
        ItemString = ""
        For k = 1 To 40
TestSame:   Randomize
            itemnum(k) = Int(itemupperbound) * Rnd
            If itemnum(k) = itemupperbound Then
                GoTo TestSame
            Else
            End If
            If k = 1 Then
            Else
                For l = 1 To k - 1
                    If (itemnum(k) - itemnum(l)) = 0 Then
                        GoTo TestSame
                    Else
                    End If
                Next l
            End If
        Next k
            Call QuickSort(itemnum(), 1, UBound(itemnum))
        For m = 1 To 40
            If itemnum(m) < 100 Then
                If itemnum(m) >= 10 Then
                    ItemString = ItemString + "I" + "0" + CStr(itemnum(m))
                Else
                    ItemString = ItemString + "I" + "00" + CStr(itemnum(m))
                End If
            Else
                ItemString = ItemString + "I" + CStr(itemnum(m))
            End If
        Next m
            Gendata_rs.AddNew
            Gendata_rs!item = ItemString
            Gendata_rs.Update
            Gendata_rs.MoveNext

    Next j
End Function
Public Function GenCanditator(ALi() As ItemNode, n As Integer)

End Function
Public Function TransGen2Item(Str1 As String, n As Integer)
Dim TransTotal2ItemNum, TransTemp2ItemNum As Integer
TransTotal2ItemNum = (n - 1) * n / 2
Dim TransTemp2ItemStr(0 To TransTotal2ItemNum - 1) As String
TransTemp2ItemNum = 0
''''''''''''此处需要改变一下 用L1Num 可以减少循环次数
Next i

For i = 0 To n - 1
    For j = i + 1 To n - 1
        TransTemp2ItemStr(TransTemp2ItemNum) = "I" + ItemStr(i) + "I" + item(j)
        TransH2Gen 100, Val(ItemStr(i)), Val(item(j)), TransTemp2ItemStr(TransTemp2ItemNum)
    Next j
Next i
End Function
Public Function TransH2Gen(itemnum As Integer, firstnum As Integer, secondnum As Integer, NodeStr As String)
Dim i, j, itemnum, H2num, firstnum, secondnum As Integer
H2num = 0
For i = 2 To firstnum
    H2num = H2num + (itemnum - i + 1)
Next i
H2num = H2num + (secondnum - firstnum)
H2(H2num).ItemStr = NodeStr
H2(H2num).ItemStrCount = H2(H2num).ItemStrCount + 1
End Function