frmga.frm

遗传算法(Genetic Algorithm, GA)是近几年发展起来的一种崭新的全局优化算法

      Left            =   360
      TabIndex        =   10
      Top             =   5400
      Width           =   1215
   End
   Begin VB.Label Label1 
      Caption         =   "遗传算法演示"
      BeginProperty Font 
         Name            =   "华文行楷"
         Size            =   27.75
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   495
      Left            =   2400
      TabIndex        =   3
      Top             =   240
      Width           =   3375
   End
End
Attribute VB_Name = "FrmGA"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Combo1_Click()
Dim j As Integer
If MM1 <> 0 Then
For j = 1 To NN
Text1((MM1 - 1) * NN + j).ForeColor = RGB(0, 0, 0)
Next j
End If
M1 = Combo1.Text
For j = 1 To NN
Text1((M1 - 1) * NN + j).ForeColor = RGB(0, 0, 255)
Next j
MM1 = M1
End Sub

Private Sub Combo2_Click()
Dim j As Integer
If MM2 <> 0 Then
For j = 1 To NN
Text1((MM2 - 1) * NN + j).ForeColor = RGB(0, 0, 0)
Next j
End If
M2 = Combo2.Text
For j = 1 To NN
Text1((M2 - 1) * NN + j).ForeColor = RGB(0, 200, 0)
Next j
MM2 = M2
End Sub

Private Sub Combo3_Click()
Dim i, j As Integer
N = Combo3.Text
Line1.Visible = True
Line1.X1 = Text1(N).Left
Line1.Y1 = 0
Line1.X2 = Text1((MM - 1) * NN + N).Left
Line1.Y2 = Picture2.Height
End Sub

Private Sub Command1_Click()
Call Read_A
Call Exchange_A
Call Calculate_A
Call Write_A
Call Write_Calculate
Call Find_Optimum
If Mark < MarkTemp Then
Mark = MarkTemp
Call Write_Optimum
End If
End Sub
Private Sub Read_A()
Dim i, j As Integer
For i = 0 To MM - 1
 For j = 1 To NN
  A(i + 1, j) = Val(Text1(i * NN + j).Text)
 Next j
Next i
End Sub

Private Sub Write_A()
Dim i, j As Integer
For i = 0 To MM - 1
 For j = 1 To NN
  Text1(i * NN + j).Text = A(i + 1, j)
 Next j
Next i
End Sub

Private Sub Write_Calculate()
Dim i As Integer
For i = 1 To MM
Text2(i).Text = B(i)
Next i
End Sub

Private Sub Write_Optimum()
Dim i As Integer
For i = 1 To NN
Text3(i).Text = A(Mark, i)
Next i
Text4.Text = B(Mark)
End Sub

Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Command3_Click()
Call Read_A
Call Calculate_A
Call Write_Calculate
Call Find_Optimum
If Mark < MarkTemp Then
Mark = MarkTemp
Call Write_Optimum
End If
End Sub

Private Sub Form_Load()
ReDim A(MM, NN)
ReDim B(MM)
MM1 = 0
MM2 = 0
Dim i As Integer
Call Pic1Redraw
Call Text1Load
Call Pic3Redraw
Call text2Load
Call Pic5Redraw
Call text3Load
For i = 1 To MM
Combo1.AddItem i
Combo2.AddItem i
Next i
For i = 1 To NN
Combo3.AddItem i
Next i
End Sub
Private Sub Pic1Redraw() '视窗图片重绘子程序
'设置表格载体图片控件的属性
Picture2.Width = NN * Text1(0).Width + 50
Picture2.Height = MM * (Text1(0).Height + 30) + 50
'判断滚动条出现的不同情况
If Picture1.Width < Picture2.Width + Picture2.Left * 2 _
   And Picture1.Height < Picture2.Height + Picture2.Top * 2 Then
'水平、垂直滚动条都出现
   HScroll1.Left = 0
   HScroll1.Top = Picture1.Height - HScroll1.Height
   HScroll1.Width = Picture1.Width
   HScroll1.Max = Picture2.Width + 2 * Picture2.Left - Picture1.Width
   HScroll1.Min = 0
   
   VScroll1.Top = 0
   VScroll1.Left = Picture1.Width - VScroll1.Width
   VScroll1.Height = Picture1.Height - HScroll1.Height
   VScroll1.Max = Picture2.Height + 2 * Picture2.Top - Picture1.Height
   VScroll1.Min = 0
   HScroll1.Visible = True
   VScroll1.Visible = True
ElseIf Picture1.Width < Picture2.Width + Picture2.Left * 2 Then
      '只出现水平滚动条
      HScroll1.Left = 0
      HScroll1.Top = Picture1.Height - HScroll1.Height
      HScroll1.Width = Picture1.Width
      HScroll1.Max = Picture2.Width + 2 * Picture2.Left - Picture1.Width
      HScroll1.Min = 0
      HScroll1.Visible = True
      VScroll1.Visible = False
   ElseIf Picture1.Height < Picture2.Height + Picture2.Top * 2 Then
         '只出现垂直滚动条
         VScroll1.Top = 0
         VScroll1.Left = Picture1.Width - VScroll1.Width
         VScroll1.Height = Picture1.Height
         VScroll1.Max = Picture2.Height + 2 * Picture2.Top - Picture1.Height
         VScroll1.Min = 0
         HScroll1.Visible = False
         VScroll1.Visible = True
      Else
        HScroll1.Visible = False
        VScroll1.Visible = False
End If
HScroll1.SmallChange = 20
HScroll1.LargeChange = (HScroll1.Max - HScroll1.Min) / 10
HScroll1.Value = 0
VScroll1.SmallChange = 20
VScroll1.LargeChange = (VScroll1.Max - VScroll1.Min) / 10
VScroll1.Value = 0
End Sub



Private Sub HScroll1_Change()  '水平滚动条变化
Picture2.Left = 0 - HScroll1.Value
End Sub

Private Sub Text1Load() '调入文本框控件
Dim i, j As Integer
For i = 0 To MM - 1 '调入水平表格中的各个文本框
  For j = 1 To NN '调入垂直表格中的各个文本框
    Load Text1(i * NN + j)
    Text1(i * NN + j).Visible = True
    Text1(i * NN + j).Left = Text1(0).Width * (j - 1)
    Text1(i * NN + j).Top = (Text1(0).Height + 30) * i
    Text1(i * NN + j).Text = ""
  Next j
Next i
End Sub

Private Sub VScroll1_Change() '垂直滚动条
Picture2.Top = 0 - VScroll1.Value
End Sub

Private Sub Pic3Redraw() '视窗图片重绘子程序
'设置表格载体图片控件的属性
Picture4.Width = 1 * Text2(0).Width + 50
Picture4.Height = MM * (Text2(0).Height + 30) + 50
'判断滚动条出现的不同情况
If Picture3.Width < Picture4.Width + Picture4.Left * 2 _
   And Picture3.Height < Picture4.Height + Picture4.Top * 2 Then
'水平、垂直滚动条都出现
   HScroll2.Left = 0
   HScroll2.Top = Picture3.Height - HScroll2.Height
   HScroll2.Width = Picture3.Width
   HScroll2.Max = Picture4.Width + 2 * Picture4.Left - Picture3.Width
   HScroll2.Min = 0
   
   VScroll2.Top = 0
   VScroll2.Left = Picture3.Width - VScroll2.Width
   VScroll2.Height = Picture3.Height - HScroll2.Height
   VScroll2.Max = Picture4.Height + 2 * Picture4.Top - Picture3.Height
   VScroll2.Min = 0
   HScroll2.Visible = True
   VScroll2.Visible = True
ElseIf Picture3.Width < Picture4.Width + Picture4.Left * 2 Then
      '只出现水平滚动条
      HScroll2.Left = 0
      HScroll2.Top = Picture3.Height - HScroll2.Height
      HScroll2.Width = Picture3.Width
      HScroll2.Max = Picture4.Width + 2 * Picture4.Left - Picture3.Width
      HScroll2.Min = 0
      HScroll2.Visible = True
      VScroll2.Visible = False
   ElseIf Picture3.Height < Picture4.Height + Picture4.Top * 2 Then
         '只出现垂直滚动条
         VScroll2.Top = 0
         VScroll2.Left = Picture3.Width - VScroll2.Width
         VScroll2.Height = Picture3.Height
         VScroll2.Max = Picture4.Height + 2 * Picture4.Top - Picture3.Height
         VScroll2.Min = 0
         HScroll2.Visible = False
         VScroll2.Visible = True
      Else
        HScroll2.Visible = False
        VScroll2.Visible = False
End If
HScroll2.SmallChange = 20
HScroll2.LargeChange = (HScroll2.Max - HScroll2.Min) / 10
HScroll2.Value = 0
VScroll2.SmallChange = 20
VScroll2.LargeChange = (VScroll2.Max - VScroll2.Min) / 10
VScroll2.Value = 0
End Sub



Private Sub hscroll2_Change()  '水平滚动条变化
Picture4.Left = 0 - HScroll2.Value
End Sub

Private Sub text2Load() '调入文本框控件
Dim i, j As Integer
For i = 0 To MM - 1 '调入水平表格中的各个文本框
  For j = 1 To 1 '调入垂直表格中的各个文本框
    Load Text2(i * 1 + j)
    Text2(i * 1 + j).Visible = True
    Text2(i * 1 + j).Left = Text2(0).Width * (j - 1)
    Text2(i * 1 + j).Top = (Text2(0).Height + 30) * i
    Text2(i * 1 + j).Text = ""
  Next j
Next i
End Sub


Private Sub vscroll2_Change() '垂直滚动条
Picture4.Top = 0 - VScroll2.Value
End Sub

Private Sub Pic5Redraw() '视窗图片重绘子程序
'设置表格载体图片控件的属性
Picture6.Width = NN * Text3(0).Width + 50
Picture6.Height = 1 * Text3(0).Height + 50
'判断滚动条出现的不同情况
If Picture5.Width < Picture6.Width + Picture6.Left * 2 _
   And Picture5.Height < Picture6.Height + Picture6.Top * 2 Then
'水平、垂直滚动条都出现
   HScroll3.Left = 0
   HScroll3.Top = Picture5.Height - HScroll3.Height
   HScroll3.Width = Picture5.Width
   HScroll3.Max = Picture6.Width + 2 * Picture6.Left - Picture5.Width
   HScroll3.Min = 0
   
   VScroll3.Top = 0
   VScroll3.Left = Picture5.Width - VScroll3.Width
   VScroll3.Height = Picture5.Height - HScroll3.Height
   VScroll3.Max = Picture6.Height + 2 * Picture6.Top - Picture5.Height
   VScroll3.Min = 0
   HScroll3.Visible = True
   VScroll3.Visible = True
ElseIf Picture5.Width < Picture6.Width + Picture6.Left * 2 Then
      '只出现水平滚动条
      HScroll3.Left = 0
      HScroll3.Top = Picture5.Height - HScroll3.Height
      HScroll3.Width = Picture5.Width
      HScroll3.Max = Picture6.Width + 2 * Picture6.Left - Picture5.Width
      HScroll3.Min = 0
      HScroll3.Visible = True
      VScroll3.Visible = False
   ElseIf Picture5.Height < Picture6.Height + Picture6.Top * 2 Then
         '只出现垂直滚动条
         VScroll3.Top = 0
         VScroll3.Left = Picture5.Width - VScroll3.Width
         VScroll3.Height = Picture5.Height
         VScroll3.Max = Picture6.Height + 2 * Picture6.Top - Picture5.Height
         VScroll3.Min = 0
         HScroll3.Visible = False
         VScroll3.Visible = True
      Else
        HScroll3.Visible = False
        VScroll3.Visible = False
End If
HScroll3.SmallChange = 20
HScroll3.LargeChange = (HScroll3.Max - HScroll3.Min) / 10
HScroll3.Value = 0
VScroll3.SmallChange = 20
VScroll3.LargeChange = (VScroll3.Max - VScroll3.Min) / 10
VScroll3.Value = 0
End Sub



Private Sub hscroll3_Change()  '水平滚动条变化
Picture6.Left = 0 - HScroll3.Value
End Sub

Private Sub text3Load() '调入文本框控件
Dim i, j As Integer
For i = 0 To 1 - 1 '调入水平表格中的各个文本框
  For j = 1 To NN '调入垂直表格中的各个文本框
    Load Text3(i * NN + j)
    Text3(i * NN + j).Visible = True
    Text3(i * NN + j).Left = Text3(0).Width * (j - 1)
    Text3(i * NN + j).Top = Text3(0).Height * i
    Text3(i * NN + j).Text = ""
  Next j
Next i
End Sub


Private Sub vscroll3_Change() '垂直滚动条
Picture6.Top = 0 - VScroll3.Value
End Sub