modnn50.bas

基于VB开发的遗传算法源程序

Attribute VB_Name = "modNN50"

Public Declare Function Train Lib "NN50.DLL" Alias "TRAIN" _
        (ByRef dwArrayPointer() As Double, lpEpochs As Long, nResetWeights As Integer, _
        nLearningRate As Double, nMomentum As Double, nMaxNeurons As Integer, _
        ByVal lpCallBackOfEpoch As Long, ByVal lpCallBackOfRMSError As Long) As Integer

Public Declare Function InputRelevance Lib "NN50.DLL" Alias "INPUTRELEVANCE" _
        (ByRef dwFromArrayPointer() As Double, ByRef dwToArrayPointer() As Double, _
        lpEpochs As Long, nLearningRate As Double, nMomentum As Double, _
        nMaxNeurons As Integer) As Integer

Public Declare Function LoadNetwork Lib "NN50.DLL" Alias "LOADNETWORK" _
        (ByRef ArrayPointer() As Double, ByVal lpFILENAME As String, _
        nLearningRate As Double, nMomentum As Double, nMaxNeurons As Integer) As Integer

Public Declare Function SaveNetwork Lib "NN50.DLL" Alias "SAVENETWORK" _
        (ByVal lpFILENAME As String) As Integer

Public Declare Function Predict Lib "NN50.DLL" Alias "PREDICT" _
        (ByRef dwArrayPointer() As Double, nLearningRate As Double, _
        nMomentum As Double, nMaxNeurons As Integer) As Double

Public Declare Function StopProcessing Lib "NN50.DLL" Alias "STOPPROCESSING" () As Integer


Public Refresh As Long
Public RMSE As Double 'Stores RMS Error
Public Const RefreshRate = 10 'Refreshes the chart on frmMain
Private iEpochs As Integer

'We must use two callback functions to return the current epoch
'and RMS error from NN50.DLL - the names are used with the AddressOf
'operator in the Train function.

Function CallBackEpoch(ByVal Epoch As Long) As Boolean

    On Error Resume Next

    If Epoch > 1000000 Then
        CallBackEpoch = False
        MsgBox "You can set CallBackEpoch equal to FALSE to stop processing" & vbCrLf & _
                "or use the StopProcessing method", vbInformation, "Example:"
    Else
        CallBackEpoch = True
    End If

    Refresh = Refresh + 1
    If Refresh = RefreshRate Then
        Refresh = 0
        frmMain.Caption = "Epoch: " & Epoch
        frmMain.picRMS.Line -(iEpochs * 4.5, 1500 - (RMSE * 3000) - 200), vbBlue
    End If

    If Epoch = 1 Then
        frmMain.picRMS.Cls
        frmMain.picRMS.CurrentX = Epoch
        frmMain.picRMS.CurrentY = 1500 - (RMSE * 3000) - 200 'Clear
    End If
    
    iEpochs = iEpochs + 1
    
    If iEpochs > 1500 Then
        iEpochs = 0
        frmMain.picRMS.Cls
        frmMain.picRMS.CurrentX = iEpochs
        frmMain.picRMS.CurrentY = 1500 - (RMSE * 3000) - 200 'Clear
    End If
    
End Function

Function CallBackRMSError(ByVal RMSError As Double) As Integer
    On Error Resume Next
    RMSE = RMSError
End Function