Листинги к статье "88 советов по оптимизации программ на Visual Basic".

Автор: Francesco Balena

[Listing 1]

Function Factorial(ByVal n As Long) As Double
    ' optimized and self-contained routine that evaluates 
    ' the factorial of a number in the range 0-170
    Dim i As Long
    Static fact(170) As Double
    Static maxValue As Long

    ' maxValue holds the highest value of "N" ever
    ' passed to this routine
    If maxValue < n Then
        fact(0) = 1
        For i = maxValue + 1 To n
            fact(i) = i * fact(i - 1)
        Next
        maxValue = n
    End If

    Factorial = fact(n)
End Function

[Listing 2]

Function AnyDuplicates(intArray() As Integer) As Boolean
    ' returns True if the array holds any duplicate values
    ' VB3 users: replace "As Boolean" with "As Integer"

    Dim i As Integer, j As Integer, lastItem As Integer
    Dim tmp As Integer

    ' evaluate UBound() only once
    lastItem = UBound(intArray)
    
    For i = LBound(intArray) To lastItem
        ' storing intArray(i) into a non-array variable
        ' saves an indexing operation within the inner 
        ' loop
        tmp = intArray(i)
        For j = i + 1 To lastItem
            If tmp = intArray(j) Then
                AnyDuplicates = True
                Exit Function
            End If
        Next
    Next
    AnyDuplicates = False
End Function

[Listing 3]

Function AnyDuplicates2(intArray() As Integer) As Boolean
    ' returns True if the array holds any duplicate values
    ' VB3 users: replace "As Boolean" with "As Integer"

    Dim i As Long, value As Integer
    Dim numEls As Long, index As Long
    Const HASH_EMPTY = -32768

    ' use a hash table twice as large as the original 
    ' array - this will minimize the number of collisions
    numEls = (UBound(intArray) - LBound(intArray) + 1) * 2
    ReDim hashTable(0 To numEls - 1) As Integer
    ' init the hash table with the "empty" value
    ' note that the original array cannot include 
    ' the -32768 value
    For i = 0 To numEls - 1
        hashTable(i) = HASH_EMPTY
    Next

    For i = LBound(intArray) To UBound(intArray)
        ' read each element of the array and store it in 
        ' the hash table; the initial position is 
        ' evaluated using the simple expression:    
        '        index = value Mod numEls
        value = intArray(i)
        index = value Mod numEls
        ' scan the hash table for an empty slot
        Do Until hashTable(index) = HASH_EMPTY
            ' if we have found another item with the same
            ' value we can exit
            If hashTable(index) = value Then
                AnyDuplicates2 = True
                Exit Function
            End If
            ' test the next slot, but wrap around at the
            ' end of the array
            index = index + 1
            If index = numEls Then index = 0
        Loop
        ' we have found an empty slot, and can store
        ' the current value there
        hashTable(index) = value
    Next
    AnyDuplicates2 = False
End Function

[Listing 4]

' WS is the current workspace
' RS is the current recordset
ws.BeginTrans
Do Until rs.EOF
    recCount = recCount + 1
    If (recCount Mod 100) = 0 Then
        ' flush the transaction buffers every 100 records
        ws.CommitTrans
        ws.BeginTrans
    End If
    ' process the current record
    ' ...
    rs.MoveNext
Loop
' commit the last changes
ws.CommitTrans

[Listing 5]

Option Explicit
Dim WithEvents cn As rdoConnection
Dim rs As rdoResultset

Private Sub Form_Load()
    ' show the form before opening the connection
    Show
    DoEvents
    ' open the connection
    Set cn = New rdoConnection
    With cn
        .Connect = "uid=;pwd=;DSN=WorkDB;"
        .CursorDriver = rdUseOdbc
        .EstablishConnection rdDriverNoPrompt
    End With
End Sub

Private Sub cmdStartQuery_Click()
    Dim sql As String
    sql = "Select * From Products Where price > 10"
    ' open the resultset running the query in asynch mode
    Set rs = cn.OpenResultset(sql, rdOpenKeyset, _
        rdConcurReadOnly, rdAsyncEnable)
End Sub

Private Sub cn_QueryComplete(ByVal Query As rdoQuery, _
    ByVal ErrorOccurred As Boolean)
        ' this event fires when the query is completed
        If ErrorOccurred Then
            MsgBox "An error is occurred while " _
                & "processing the query"
            ' in a real world program you should test
            ' rdoErrors for a more elegant recovery
        Else
            MsgBox "The query has completed. " & _
                rs.RowCount & " records were returned."
        End If
End Sub

Private Sub cn_QueryTimeout(ByVal Query As rdoQuery, _
    Cancel As Boolean)
        If MsgBox("Query time-out. Do you wish to " & _
            "retry for additional " & cn.QueryTimeout & _
            " seconds?", vbYesNo) = vbYes Then
                ' the user is willing to wait
                Cancel = False
        End If
        ' no special action is required if the user 
        ' refuses to wait since the default value for 
        ' Cancel is True
End Sub

Добавлено: 19 августа 2002