The add is working correctly
Private Sub AddColumnToTableLayout()
Me.m_TblLyBtnHost.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Percent, (100 / m_TblLyBtnHost.ColumnCount)))
For iColumnStyle As Integer = 0 To Me.m_TblLyBtnHost.ColumnStyles.Count - 1
Me.m_TblLyBtnHost.ColumnStyles.Item(iColumnStyle).SizeType = SizeType.Percent
Me.m_TblLyBtnHost.ColumnStyles.Item(iColumnStyle).Width = 100 / Me.m_TblLyBtnHost.ColumnCount
Next
'For iColumns As Integer = 0 To m_TblLyBtnHost.ColumnCount - 1
' Me.m_TblLyBtnHost.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Percent, (100 / m_TblLyBtnHost.ColumnCount)))
'Next
'Insert buttons for each of the new row ends
For iRowIndex As Integer = 0 To Me.m_TblLyBtnHost.RowCount - 1
m_btnMy = New MyButton.MyButton
Me.SetDefaultsOnMyButtonMyButton(m_btnMy, Me.m_TblLyBtnHost.ColumnCount, iRowIndex)
Me.m_TblLyBtnHost.Controls.Add(m_btnMy, Me.m_TblLyBtnHost.ColumnCount, iRowIndex)
Next
End Sub
The MyButton.MyButton is declared in the the class for the UserControl as
Friend WithEvents m_btnMy As MyButton.MyButton
The Remove function however isn't
Private Sub RemoveColumnFromTableLayout()
For iRowIndex As Integer = 0 To Me.m_TblLyBtnHost.RowCount - 1
Dim Ctrl As MyButton.MyButton = Me.m_TblLyBtnHost.GetControlFromPosition(iRowIndex, Me.m_TblLyBtnHost.ColumnCount - 1)
Me.m_TblLyBtnHost.Controls.Remove(Ctrl)
Next
Me.m_TblLyBtnHost.ColumnStyles.RemoveAt(Me.m_TblLyBtnHost.ColumnCount - 1)
For iColumnIndex As Integer = 0 To Me.m_TblLyBtnHost.ColumnStyles.Count - 1
Me.m_TblLyBtnHost.ColumnStyles.Item(iColumnIndex).Width = 100 / Me.m_TblLyBtnHost.ColumnCount
Next
End Sub
In stepping through RemoveColumnFromTableLayout() I noticed that GetControlFromPosition is returning "Nothing". I started with a 2x2 matrix and after adding a column I correctly have a 2x3 matrix with button. After a remove I incorrect have a 3x2 matrix of the same button set. I tried using a dispose on the control before I realized that the GetControl was returning "Nothing".
Thanks for any help.
Some general notes:
You have to explicitly increment/decrement the ColumnCount()
property.
The ColumnStyle() Width property does NOT need to be an actual
computed percentage. Simply make all the columns have the same
value. I've used whatever value is in the first column. With that
in mind, you don't have to change any of the Widths when a column is
removed, since they are all the same value already.
You had an "off by one" error in the Column value for the Add()
routine.
In the Remove() routine, your row/col parameters were Reversed in
the GetControlFromPosition() call.
Here's the revised code:
Private Sub AddColumnToTableLayout()
Me.m_TblLyBtnHost.ColumnCount = Me.m_TblLyBtnHost.ColumnCount + 1
Me.m_TblLyBtnHost.ColumnStyles.Add(New System.Windows.Forms.ColumnStyle(System.Windows.Forms.SizeType.Percent, Me.m_TblLyBtnHost.ColumnStyles(0).Width))
'Insert buttons for each of the new row ends
For iRowIndex As Integer = 0 To Me.m_TblLyBtnHost.RowCount - 1
m_btnMy = New MyButton.MyButton
Me.SetDefaultsOnMyButtonMyButton(m_btnMy, Me.m_TblLyBtnHost.ColumnCount - 1, iRowIndex)
Me.m_TblLyBtnHost.Controls.Add(m_btnMy, Me.m_TblLyBtnHost.ColumnCount - 1, iRowIndex)
Next
End Sub
Private Sub RemoveColumnFromTableLayout()
For iRowIndex As Integer = 0 To Me.m_TblLyBtnHost.RowCount - 1
Me.m_TblLyBtnHost.GetControlFromPosition(Me.m_TblLyBtnHost.ColumnCount - 1, iRowIndex).Dispose()
Next
Me.m_TblLyBtnHost.ColumnStyles.RemoveAt(Me.m_TblLyBtnHost.ColumnCount - 1)
Me.m_TblLyBtnHost.ColumnCount = Me.m_TblLyBtnHost.ColumnCount - 1
End Sub
Related
I need your help to prepare data. I am reading a byte array. I make bytes to unsigned integers. I read in different blocks of that array and write the UInt32s in 5 lists in total. The data has been stored compressed; that is, some spaces are missing and I need to fill them up. To make it clear, I made a compilable test project for you and wrote the data into an excel file.
This is the original data. From the left to the right: Sizes, Addresses, Indexes, Number_of_items, Description
You can see that in column C the 2, 3, and 4 are missing. So I select columns C through E, and move them down 3 rows. I fill the gaps with 2, 3, 4 in column C and 1, 1, 1 in the other two columns.
I do this until I reach the end of column B. Columns B, C, D, and E must have the same length.
Where I have a little problem
I fail because a While or For loop evaluates the List.Count property only once. That is, if I add something to a list within the loop, the loop doesn't run often enough. I've provisionally worked around this by writing While True and catching an OutOfRangeException. Maybe someone has a better idea; or even an idea that completely replaces my approach :D
Step № 2
If a row has a 2 in column D, I select columns B through E below the 2, and move the contents down one row (only one, because the difference is 1).
I want to do this until I get to the bottom of the table. This will make all columns the same length.
Again, I have the problem that I use While True and go out using an exception. Does anyone have a better idea?
FormMain.vb
Public NotInheritable Class FormMain
Private Sizes As New List(Of UInt32) From {
58_355UI,
20_270UI,
4_830UI,
4_443UI,
25_177UI,
8_844UI,
4_101UI,
4_200UI,
14_991UI,
12_639UI,
12_894UI,
14_165UI,
12_954UI,
26_670UI,
7_388UI}
Private Addresses As New List(Of UInt32) From {4_323UI, 62_706UI, 83_646UI, 88_935UI, 93_883UI, 128_259UI, 132_718UI,
137_254UI, 152_590UI, 178_485UI, 193_022UI, 206_718UI}
Private Indexes As New List(Of UInt32) From {1UI, 5UI, 6UI, 9UI, 10UI, 12UI}
Private NumberOfItems As New List(Of UInt32) From {1UI, 2UI, 1UI, 2UI, 1UI, 2UI}
Private Description As New List(Of UInt32) From {1UI, 1UI, 1UI, 1UI, 1UI, 1UI}
Private Sub ButtonStart_Click(sender As Object, e As EventArgs) Handles ButtonStart.Click
Dim RopD As New Reprocessing_of_parsed_data(Sizes, Addresses, Indexes, NumberOfItems, Description)
RopD.Fill_gaps()
End Sub
End Class
Reprocessing_of_parsed_data.vb
Public NotInheritable Class Reprocessing_of_parsed_data
Public Property Sizes As New List(Of UInteger)
Public Property Addresses As New List(Of UInteger)
Public Property Indexes As New List(Of UInteger)
Public Property Number_of_items As New List(Of UInteger)
Public Property Description As New List(Of UInteger)
Public Sub New(sizes As List(Of UInt32), addresses As List(Of UInt32), indexes As List(Of UInt32), number_of_items As List(Of UInt32), description As List(Of UInt32))
Me.Sizes = sizes
Me.Addresses = addresses
Me.Indexes = indexes
Me.Number_of_items = number_of_items
Me.Description = description
End Sub
Public Sub Fill_gaps()
Dim counterForAddressesList As Integer = 0
'Dim ListCount As Integer = Indexes.Count - 2
Dim i As Integer = 0
While True 'i < ListCount - 2
Try
Dim delta As Integer = CInt(Indexes(i + 1) - Indexes(i)) - 1
Dim number As UInt32 = Indexes(i)
While delta > 0
number += 1UI
counterForAddressesList += 1
Indexes.Insert(CInt(number) - 1, number)
Number_of_items.Insert(CInt(number) - 1, 1UI)
Description.Insert(CInt(number) - 1, 1UI)
delta -= 1
'ListCount += 1
End While
counterForAddressesList += 1
i += 1
Catch ex As ArgumentOutOfRangeException
Exit While
End Try
End While
' Step 2
Dim j As Integer = 0
While True
Try
If Number_of_items(j) > 1UI Then
Dim delta As Integer = CInt(Number_of_items(j)) - 1
While delta > 0
Addresses.Insert(j + 1, UInteger.MaxValue)
Indexes.Insert(j + 1, UInteger.MaxValue)
Number_of_items.Insert(j + 1, UInteger.MaxValue)
Description.Insert(j + 1, UInteger.MaxValue)
delta -= 1
j += 1
End While
End If
j += 1
Catch ex As ArgumentOutOfRangeException
Exit While
End Try
End While
End Sub
End Class
It is never a good idea to catch an index out of bounds exception in a Try-Catch-statement. Only conditions you are not in control of (often I/O errors) should be handled at runtime. An index being out of bounds is a design error and must be fixed at design time.
I extracted the two steps from Sub Fill_gaps into two new methods to make the code easier to read and test.
Public Sub Fill_gaps() ' A better name would be "Decompress"
PrintTable() 'For testing
FillGaps()
PrintTable() 'For testing
AddMissingNumberOfItems()
PrintTable() 'For testing
End Sub
I also added a method PrintTable for testing
Private Sub PrintTable()
Console.WriteLine()
Console.WriteLine($" A B C D E")
For i = 0 To Sizes.Count - 1
Dim A = Sizes(i)
Dim B = If(i < Addresses.Count, Addresses(i), 0UI)
Dim C = If(i < Indexes.Count, Indexes(i), 0UI)
Dim D = If(i < NumberOfItems.Count, NumberOfItems(i), 0UI)
Dim E = If(i < Description.Count, Description(i), 0UI)
Console.WriteLine($"{A,10}{B,10}{C,10}{D,10}{E,10}")
Next
End Sub
Step 1: fill the gaps (the method is self-explanatory):
Private Sub FillGaps()
' Fill gaps in columns C, D and E.
' The number of Addresses B indicates the total number of indexes.
' Append empty items to C, D and E until the list counts matches the
' expected total number of indexes.
Dim originalIndexCount = Indexes.Count 'Save original count
Do While Indexes.Count < Addresses.Count
Indexes.Add(CUInt(Indexes.Count + 1)) ' Make index 1-based
NumberOfItems.Add(1)
Description.Add(1)
Loop
'Move the rows to where the index indicates.
'We do it backwards to not overwrite existing items.
For i As Integer = originalIndexCount - 1 To 0 Step -1
Dim targetIndex = CInt(Indexes(i)) - 1 ' Subtract 1, indexes are 0-based
If targetIndex <> i Then
' Copy to target position
Indexes(targetIndex) = Indexes(i)
NumberOfItems(targetIndex) = NumberOfItems(i)
Description(targetIndex) = Description(i)
'Clear resp. initialize old row
Indexes(i) = CUInt(i + 1) ' Make index 1-based
NumberOfItems(i) = 1
Description(i) = 1
End If
Next
End Sub
Step 2:
Private Sub AddMissingNumberOfItems()
' Insert empty rows after items with NumberOfItems > 1.
' We do it backwards to not mess up our indexes.
For i As Integer = Indexes.Count - 1 To 0 Step -1
For k As UInteger = 2 To NumberOfItems(i)
Addresses.Insert(i + 1, 0)
Indexes.Insert(i + 1, 0)
NumberOfItems.Insert(i + 1, 0)
Description.Insert(i + 1, 0)
Next
Next
End Sub
If you use the following test list for the descriptions, you will better see which rows have been moved or added
Private Description As New List(Of UInt32) From {2UI, 3UI, 4UI, 5UI, 6UI, 7UI}
I add some values to my array and try to get it later in another method.
Unfortunately i get an compline error for my array when i try to get the value.
The values for the array comes from my UserForm, where some checkboxes could be selected. While closing the UserForm a method runs and controlls which checkboxes are activated, if the checkbox value is true the name of the checkbox should be add to the array
'''ThisDocument Code
Public Processes As Variant 'This is the Array
Public numberOfProcesses As Integer
'''UserForm1 Code
public sub controllProcesses()
numberOfProcesses = 0
If cbLogin.Value = True Then
numberOfProcesses = numberOfProcesses + 1
ReDim Processes(numberOfProcesses)
Processes(numberOfProcesses - 1) = "Login"
End If
If cbRegistration.Value = True Then
numberOfProcesses = numberOfProcesses + 1
ReDim Processes(numberOfProcesses)
Processes(numberOfProcesses - 1) = "Registration"
End If
End Sub
'''Method to get value from array
Public Sub Examples()
Dim a As Integer
Dim b As Integer
b = 1
With Selection
For a = 0 To numberOfProcesses
.TypeText Text:=b & ". " & Processes(a) ' Here the compile error appears.
Next
End With
End Sub
From what I could find via my search, it should actually work like this, but I don't know what I'm doing wrong.
I have a data grid view where I need the columns to be frozen or fixed when scrolling vertically.
I have a data grid view control in vb.net windows application which displays the data in a parent-child hierarchy(as shown below). The first column displays the parent data and the second column displays all its child data. The child data in the second column can be as much as 100 rows or even more. So when scrolling down through the grid, the value in the first column does not remain there as it is while the values in the second column(i.e. the child data) scrolls down. So if the user wants to check to which parent, the current child info belongs to, then again he will have to scroll up to the starting of the column to find the name of the parent. I want the values in the first column to be displayed or frozen till it reaches the end of the list of its child values in the grid or at least till the next row where the next parent data starts. I have suggested the client to go with a tree view but they are not agreeing and need it in a data grid view itself. Is there anyway to achieve this in a data grid view?
Thanks in advance.
You can't freeze a row (in runtime, on dgv scrolling) with index greater than zero because all those before are frozen and at that point you can't scroll your datagridview.
If I understood correctly what you want I wrote this class quickly (probably should be optimized). Usage is simple.
1 - First create your own datagridview.
2 - then add your columns and rows (IMPORTANT: Put a “X” in the Tag in each row is a Parent or is considered as title for other rows as you seen in TestPopulate method) .
3 - Call the class I made by passing the datagridview (you created first) as a parameter. At this point this control takes its size, placement and REPLACE YOUR DATAGRIDVIEW .
Private Class CustomDgv
Inherits Panel
Dim WithEvents TopDgv As DataGridView = New DataGridView
Dim WithEvents DownDgv As DataGridView = New DataGridView
Dim Cols As Integer
' This variable is in case you have more rows as "headrow"
' In TestPopulate you can see how to get those
Dim listOfOwnerRows As List(Of Integer) = New List(Of Integer)
Dim currentTopRow As Integer = -1
Protected Overloads Property Height As Integer
Get
Return MyBase.Height
End Get
Set(value As Integer)
MyBase.Height = value
TopDgv.Height = TopDgv.RowTemplate.Height - 1
DownDgv.Height = value - TopDgv.Height - 1
End Set
End Property
Protected Overloads Property Width As Integer
Get
Return MyBase.Width
End Get
Set(value As Integer)
MyBase.Width = value
TopDgv.Width = value - 1
DownDgv.Width = value - 1
End Set
End Property
Sub New(dgvOriginal As DataGridView)
DownDgv = dgvOriginal
Dim parentCtrl As Control = dgvOriginal.Parent
parentCtrl.Controls.Remove(dgvOriginal)
parentCtrl.Controls.Add(Me)
Me.Location = DownDgv.Location
Me.Size = DownDgv.Size
Me.BorderStyle = DownDgv.BorderStyle
TopDgv.Width = Width - 2 - SystemInformation.VerticalScrollBarWidth
TopDgv.Height = TopDgv.RowTemplate.Height
TopDgv.ScrollBars = ScrollBars.None
TopDgv.ColumnHeadersVisible = False
TopDgv.BorderStyle = BorderStyle.None
DownDgv.ColumnHeadersVisible = False
DownDgv.BorderStyle = BorderStyle.None
TopDgv.Left = 0
DownDgv.Left = 0
DownDgv.Width = Width - 2
DownDgv.Height = Height - 2
For Each Col As DataGridViewColumn In DownDgv.Columns
Dim cIndex As Integer = TopDgv.Columns.Add(Col.Clone)
If Col.Frozen Then
TopDgv.Columns(cIndex).Frozen = True
End If
Cols += 1
Next
DownDgv.Top = 0
Me.Controls.Add(TopDgv)
Me.Controls.Add(DownDgv)
If DownDgv.Rows.Count > 0 Then
listOfOwnerRows = (From R As DataGridViewRow In DownDgv.Rows
Where R.Tag = "X"
Select R.Index).ToList
If listOfOwnerRows.Count > 0 Then
SetFrosenRow(listOfOwnerRows(0))
End If
End If
End Sub
Protected Sub SetFrosenRow(index As Integer)
If DownDgv.Rows.Count > index Then
TopDgv.Rows.Clear()
TopDgv.Rows.Add()
Dim currentRIndex As Integer = DownDgv.FirstDisplayedScrollingRowIndex
'If you want onlly the base row
For i As Integer = 0 To Cols - 1
TopDgv.Rows(0).Cells(i).Value = DownDgv.Rows(index).Cells(i).Value
Next
'Or else get the diplayed on top row
TopDgv.Rows(0).DefaultCellStyle = New DataGridViewCellStyle With {
.BackColor = Color.Bisque
}
currentTopRow = index
End If
End Sub
Protected Sub SetChildValuesInTopRow(index As Integer)
For i As Integer = 1 To Cols - 1
TopDgv.Rows(0).Cells(i).Value = DownDgv.Rows(index).Cells(i).Value
Next
End Sub
Private Sub DownDgv_Scroll(sender As Object, e As ScrollEventArgs) Handles DownDgv.Scroll
Try
If e.ScrollOrientation = ScrollOrientation.VerticalScroll Then
Dim topR As Integer = DownDgv.FirstDisplayedScrollingRowIndex
'If you want in top row the current value that is in the top uncomment this
SetChildValuesInTopRow(topR)
If listOfOwnerRows.Count > 0 Then
Dim rToSetAsOwner As Integer = listOfOwnerRows(listOfOwnerRows.Count - 1)
For i As Integer = listOfOwnerRows.Count - 1 To 0 Step -1
If listOfOwnerRows(i) <= topR Then
rToSetAsOwner = listOfOwnerRows(i)
Exit For
End If
Next
If rToSetAsOwner <> currentTopRow Then
SetFrosenRow(rToSetAsOwner)
End If
Console.WriteLine("rToSetAsOwner: " & rToSetAsOwner)
End If
Else
TopDgv.HorizontalScrollingOffset = DownDgv.HorizontalScrollingOffset
End If
Catch ex As Exception
Console.WriteLine(ex.ToString)
End Try
End Sub
End Class
Usage:
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles Me.Load
Try
' first populate you grid putting a tag in each row which is a header/parent/title for other rows
TestPopulate()
Dim customControl As Control = New CustomDgv(DataGridView1)
Catch ex As Exception
Console.WriteLine(ex.ToString)
End Try
End Sub
Sub TestPopulate()
For i As Integer = 0 To 100
DataGridView1.Rows.Add()
If i = 0 Then
DataGridView1.Rows.Item(0).Cells(0).Value = "Owner 0"
DataGridView1.Rows(0).Tag = "X"
End If
If i = 50 Then
DataGridView1.Rows.Item(50).Cells(0).Value = "Owner 50"
DataGridView1.Rows(50).Tag = "X"
End If
If i = 70 Then
DataGridView1.Rows.Item(70).Cells(0).Value = "Owner 70"
DataGridView1.Rows(70).Tag = "X"
End If
DataGridView1.Rows.Item(i).Cells(1).Value = "child_" & i.ToString & "_1"
DataGridView1.Rows.Item(i).Cells(2).Value = "child_" & i.ToString & "_2"
Next
End Sub
I hope I have been helpful
I have a list box contains 10 times . I have UP and Down buttons to move item up and down. My VBA works only if i set listbox multiselect property to 'None'. For the multiselect=simple option it throws error like in valid use of null in this line of code
sText = lbfNames.Column(0, iIndex)
My VBA
Private Sub cmdUP_Click()
Dim sText As String
Dim iIndex As Integer
iIndex = lbfNames.ListIndex
'check: only proceed if there is a selected item
If lbfNames.ListCount > 1 Then
'index 0 is top item which can't be moved up!
If iIndex <= 0 Then
MsgBox ("Can not move the item up any higher.")
Exit Sub
End If
' If iIndex = -1 Or lbfNames.ListCount > 1 Then
'save items text and items indexvalue
sText = lbfNames.Column(0, iIndex)
lbfNames.RemoveItem iIndex
'place item back on new position
lbfNames.AddItem sText, iIndex - 1
'if you keep that item selected
'you can keep moving it by pressing cmdUp
lbfNames.Selected(iIndex - 1) = True
iIndex = iIndex - 1
End If
End sub
And i was trying to convert the below C# code(found in stackoverflow) to Access VBA throwing errors. Some data members not found.
public void MoveUp()
{
MoveItem(-1);
}
public void MoveDown()
{
MoveItem(1);
}
public void MoveItem(int direction)
{
// Checking selected item
if (listBox1.SelectedItem == null || listBox1.SelectedIndex < 0)
return; // No selected item - nothing to do
// Calculate new index using move direction
int newIndex = listBox1.SelectedIndex + direction;
// Checking bounds of the range
if (newIndex < 0 || newIndex >= listBox1.Items.Count)
return; // Index out of range - nothing to do
object selected = listBox1.SelectedItem;
// Removing removable element
listBox1.Items.Remove(selected);
// Insert it in new position
listBox1.Items.Insert(newIndex, selected);
// Restore selection
listBox1.SetSelected(newIndex, true);
}
Is there anyway to do this in access vba.
if you don't want the wrap around feature modify the above solution to this ..
Option Explicit
Private Enum directions
down = -1
up = 1
End Enum
Private Sub cmdDown_Click()
moveListItem (down)
End Sub
Private Sub cmdMvUp_Click()
moveListItem (up)
End Sub
Private Sub moveListItem(direction As directions)
With Me.ListBox1
Select Case .ListIndex
' at bottom and moving down then wrap around to top
Case Is >= .ListCount + direction
' at top and moving up then wrap around to bottom
Case Is < direction
Case Else
.AddItem .Column(0, .ListIndex - direction), .ListIndex + ((direction + 1) / 2)
.RemoveItem (.ListIndex - direction)
End Select
End With
End Sub
I actually reconstructed this setting but could never get the error you mentioned. I did play around with the code to adjust it to what you were trying to do. Try this:
Private Sub cmdup_Click()
Dim sText As String
Dim iIndex As Variant
Dim selection() As Integer
Dim n, topSelection As Integer
' save the indexes of the selected items,
' they will be deselected after the first removal
For Each iIndex In lbfnames.ItemsSelected
ReDim Preserve selection(0 To n)
selection(n) = iIndex
n = n + 1
Next
'loop through all the selected indexes
'this will also ensure you will only proceed if there is a selected item
For n = LBound(selection) To UBound(selection)
'save items text and items indexvalue
sText = lbfnames.Column(0, selection(n))
If selection(n) <= topSelection Then 'index topSelection is top item which can't be moved up!
MsgBox ("Can not move item '" & sText & "' up any higher.")
topSelection = topSelection + 1
Else
'first remove item from old position
lbfnames.RemoveItem selection(n)
'place item back on new position
lbfnames.AddItem sText, selection(n) - 1
'change the index of the selected value to the new index (for reselection)
selection(n) = selection(n) - 1
End If
Next
'loop through the selection again to reselect
For n = LBound(selection) To UBound(selection)
lbfnames.Selected(selection(n)) = True
Next
End Sub
The code and comments are self-explanatory I think, but here is a quick run-through:
I save the selected elements indexes first because I noticed
after the removal/addition of the element that the selection was
gone.
I then run through this selection, I reused your code here.
Changed the condition for the pop up message, because if you select
the top 2 elements for example (say 1 and 2), you don't want to only
get the messagebox for 1 and then in the next loop put 2 ahead of 1.
(Unless that is what you want, then change this condition back to 0)
Add the end I loop through the selected elements a second time to select them again for moving them further up the list.
Note: the example C# code shows a more generic function for both directions of movement. I did not adapt that, I think that is a good idea but leave it to you to implement (always a good exercise to understand the code).
The following code is type safe for direction by using an enum.
The solution allows movement up and down the list.
The solution wraps the movement (e.g. if at top of list and attempting to move up it wraps the item to the bottom.
Private Enum directions
down = -1
up = 1
End Enum
Private Sub cmdDown_Click()
moveListItem (down)
End Sub
Private Sub cmdMvUp_Click()
moveListItem (up)
End Sub
Private Sub moveListItem(direction As directions)
With Me.ListBox1
Select Case .ListIndex
' at bottom and moving down then wrap around to top
Case Is >= .ListCount + direction
.AddItem .Column(0, .ListCount - 1), 0
.RemoveItem (.ListCount - 1)
.Selected(0) = True
' at top and moving up then wrap around to bottom
Case Is < direction
.AddItem .Column(0, 0), .ListCount
.RemoveItem (0)
.Selected(.ListCount - 1) = True
Case Else
.AddItem .Column(0, .ListIndex - direction), .ListIndex + ((direction + 1) / 2)
.RemoveItem (.ListIndex - direction)
End Select
End With
End Sub
I have exhausted all of my options and am very desperate for help since I cannot figure out where the bug in my code is, or if there is something I don't understand.
I'm trying to create a "methinks it is a weasel!" mimmick from Richard Dawkins' late 80s documentary about evolution. The goal is to progress through a genetic algorithm until the algorithm guesses the correct answer through mutation and fitness tournaments.
Now, here's the problem:
Private Function fitnessTourney(ByVal editGuess() As Guess, ByVal popIndex As Integer, ByVal tourneySize As Integer, ByVal popNum As Integer)
Dim randInt(tourneySize - 1) As Integer
Dim loopCount1 As Integer = 0
Dim fitnessWinner As New Guess
fitnessWinner.setFitness(-50)
...
And, this loop is where I am experiencing the critical error
...
For i = 0 To tourneySize - 1
Randomize()
randInt(i) = Int(Rnd() * popNum)
While editGuess(randInt(i)).Used = True
If loopCount1 > tourneySize Then
loopCount1 = 0
For i2 = 0 To popNum - 1
editGuess(i2).setUsed(False)
Next
i = -1
Continue For
End If
loopCount1 += 1
randInt(i) = Int(Rnd() * popNum)
End While
editGuess(randInt(i)).determineFitness(correctPhrase)
editGuess(randInt(i)).setUsed(True)
Next
For i = 0 To popNum - 1
editGuess(i).setUsed(False)
Next
What this loop is trying to do is pick out four random instances of the editGuess array of objects. This loop tries to prevent one from being used multiple times, as the population is competing to one of the 10 members (highest fitness of the 4 chosen candidates is supposed to win).
The critical error is that I mysteriously get an endless loop where any instances of editGuess(randInt(i)).Used will always evaluate to true. I have tried to fix this by resetting all instances to False if it loops too many times.
The stumper is that I'll have all instances evaluate to False in the debugger. Then, when I reach "editGuess(randInt(i)).setUsed(True)" (the exact same thing as "editGuess(randInt(i)).Used = True"), it sets this value for EVERY member of the array.
Is there anyone who can see what is happening? I am so close to completing this!
Here's the Guess class:
Public Class Guess
Dim Fitness As Integer
Dim strLength As Integer
Dim strArray(30) As String
Dim guessStr As String
Dim Used As Boolean
Public Sub New()
Fitness = 0
guessStr = ""
strLength = 0
Used = 0
End Sub
Public Sub determineFitness(ByVal correctPhrase As String)
Dim lowerVal
If guessStr.Length <= correctPhrase.Length Then
lowerVal = guessStr.Length
Else
lowerVal = correctPhrase.Length
End If
strArray = guessStr.Split("")
Fitness = 0 - Math.Abs(correctPhrase.Length - guessStr.Length)
For i = 0 To lowerVal - 1
If correctPhrase(i) = guessStr(i) Then
Fitness = Fitness + 1
End If
Next
End Sub
Public Sub Mutate(ByVal mutatepercentage As Decimal, ByVal goodLetters As String)
If mutatepercentage > 100 Then
mutatepercentage = 100
End If
If mutatepercentage < 0 Then
mutatepercentage = 0
End If
mutatepercentage = mutatepercentage / 100
If Rnd() < mutatepercentage Then
strLength = Int(Rnd() * 25) + 5
If strLength < guessStr.Length Then
guessStr = guessStr.Remove(strLength - 1)
End If
End If
For i = 0 To strLength - 1
If Rnd() < mutatepercentage Then
If i < guessStr.Length Then
guessStr = guessStr.Remove(i, 1).Insert(i, goodLetters(Int(Rnd() * goodLetters.Length)))
Else
guessStr = guessStr & goodLetters(Int(Rnd() * goodLetters.Length))
End If
End If
Next
End Sub
Public Sub setFitness(ByVal num As Integer)
Fitness = num
End Sub
Public Sub setStrLength(ByVal num As Integer)
strLength = num
End Sub
Public Sub initializeText()
End Sub
Public Sub setUsed(ByVal bVal As Boolean)
Used = bVal
End Sub
End Class
And, finally, here's where and how the function is called
Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer1.Tick
population1(counter) = fitnessTourney(population1, counter, 4, 10)
population2(counter) = fitnessTourney(population2, counter, 4, 10)
population1(counter).Mutate(2, goodLetters)
population2(counter).Mutate(20, goodLetters)
Label1.Text = population1(counter).guessStr
Label2.Text = population2(counter).guessStr
counter += 1
If counter > 9 Then
counter = 0
End If
End Sub
End Class
EDIT 1:
Thank you guys for your comments.
Here is the custom constructor I use to the form. This is used to populate the population arrays that are passed to the fitnessTourney function with editGuess.
Public Sub New()
InitializeComponent()
Randomize()
For i = 0 To 9
population1(i) = New Guess
population2(i) = New Guess
Next
counter = 0
correctPhrase = "Methinks it is a weasel!"
goodLetters = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ !##$%^&*()_+-=?></.,;\|`'~"
goodLettersArr = goodLetters.Split("")
For i = 0 To 9
population1(i).setStrLength(Int(Rnd() * 25) + 5)
population2(i).setStrLength(Int(Rnd() * 25) + 5)
For i2 = 0 To population1(i).strLength
population1(i).guessStr = population1(i).guessStr & goodLetters(Int(Rnd() * goodLetters.Length))
Next
For i2 = 0 To population2(i).strLength
population2(i).guessStr = population2(i).guessStr & goodLetters(Int(Rnd() * goodLetters.Length))
Next
Label1.Text = population1(i).guessStr
Label2.Text = population2(i).guessStr
Next
population1(0).guessStr = correctPhrase
population1(0).determineFitness(correctPhrase)
End Sub
I haven't studied all of your code thoroughly, but one big problem is that you are calling Randomize from within the loop. Every time you call Randomize, it re-seeds the random numbers with the current time. Therefore, if you call it multiple times before the clock changes, you will keep getting the first "random" number in the sequence using that time which will always evaluate to the same number. When generating "random" numbers, you want to re-seed your random number generator as few times as possible. Preferably, you'd only seed it once when the application starts.
As a side note, you shouldn't be using the old VB6 style Randomize and Rnd methods. Those are only provided in VB.NET for backwards compatibility. You should instead be using the Random class. It's easier to use too. With the Random class, you don't even need to call a randomize-like method, since it automatically seeds itself at the point in time when you instantiate the object. So, in the case of the Random class, the thing to be careful is to make sure that you only instantiate the object once before entering any loop where you might be using it. If you create a new Random object inside a loop, it will similarly keep generating the same numbers.