VBA class instances - vba

I'm having an issue in VBA where every item in the array is being replaced every time i add something to that array.
I am attempting to go through the rows in a given range and cast every row of that into a custom class (named 'CustomRow' in below example). there is also a manager class (called 'CustomRow_Manager' below) which contains an array of rows and has a function to add new rows.
When the first row is added it works fine:
https://drive.google.com/file/d/0B6b_N7sDgjmvTmx4NDN3cmtYeGs/view?usp=sharing
however when it loops around to the second row it replaces the contents of the first row as well as add a second entry:
https://drive.google.com/file/d/0B6b_N7sDgjmvNXNLM3FCNUR0VHc/view?usp=sharing
Any ideas on how this can be solved?
I've created a bit of code which shows the issue, watch the 'rowArray' variable in the 'CustomRow_Manager' class
Macro file
https://drive.google.com/file/d/0B6b_N7sDgjmvUXYwNG5YdkoySHc/view?usp=sharing
otherwise code is below:
Data
A B C
1 X1 X2 X3
2 xx11 xx12 xx13
3 xx21 xx22 xx23
4 xx31 xx32 xx33
Module "Module1"
Public Sub Start()
Dim cusRng As Range, row As Range
Set cusRng = Range("A1:C4")
Dim manager As New CustomRow_Manager
Dim index As Integer
index = 0
For Each row In cusRng.Rows
Dim cusR As New CustomRow
Call cusR.SetData(row, index)
Call manager.AddRow(cusR)
index = index + 1
Next row
End Sub
Class module "CustomRow"
Dim iOne As String
Dim itwo As String
Dim ithree As String
Dim irowNum As Integer
Public Property Get One() As String
One = iOne
End Property
Public Property Let One(Value As String)
iOne = Value
End Property
Public Property Get Two() As String
Two = itwo
End Property
Public Property Let Two(Value As String)
itwo = Value
End Property
Public Property Get Three() As String
Three = ithree
End Property
Public Property Let Three(Value As String)
ithree = Value
End Property
Public Property Get RowNum() As Integer
RowNum = irowNum
End Property
Public Property Let RowNum(Value As Integer)
irowNum = Value
End Property
Public Function SetData(row As Range, i As Integer)
One = row.Cells(1, 1).Text
Two = row.Cells(1, 2).Text
Three = row.Cells(1, 3).Text
RowNum = i
End Function
Class module "CustomRow_Manager"
Dim rowArray(4) As New CustomRow
Dim totalRow As Integer
Public Function AddRow(r As CustomRow)
Set rowArray(totalRow) = r
If totalRow > 1 Then
MsgBox rowArray(totalRow).One & rowArray(totalRow - 1).One
End If
totalRow = totalRow + 1
End Function

Your issue is using
Dim cusR As New CustomRow
inside the For loop. This line is actually only executed once (note that when you single F8 step through the code it does not stop on that line)
Each itteration of the For loop uses the same instance of cusR. Therefore all instances of manager added to the class point to the same cusR
Replace this
For Each row In cusRng.Rows
Dim cusR As New CustomRow
with this
Dim cusR As CustomRow
For Each row In cusRng.Rows
Set cusR = New CustomRow
This explicitly instantiates a new instance of the class

Related

VB.net - Sorting only one column in datagridview

I'm populating a DataGridView from an Excel file, and trying to sort only ONE column of my choice, other columns should remain as-is. How can it be achieved? Should the component be changed to something else, in case it is not possible in DataGridView?
I Created a List of my custom class, and this class will handle the sorting based on my preference (Randomization in this case)
Public Class Mylist
Implements IComparable(Of Mylist)
Private p_name As String
Private r_id As Integer
Public Property Pname() As String 'This will hold the contents of DGV that I want sorted
Get
Return p_name
End Get
Set(value As String)
p_name = value
End Set
End Property
Public Property Rid() As Integer 'This will be the basis of sort
Get
Return r_id
End Get
Set(value As Integer)
r_id = value
End Set
End Property
Private Function IComparable_CompareTo(other As Mylist) As Integer Implements IComparable(Of Mylist).CompareTo
If other Is Nothing Then
Return 1
Else
Return Me.Rid.CompareTo(other.Rid)
End If
End Function
End Class
Then a Button which will sort the contents:
Dim selcol = xlView.CurrentCell.ColumnIndex
Dim rand = New Random()
Dim x As Integer = 0
Dim plist As New List(Of Mylist)
Do While x < xlView.Rows.Count
plist.Add(New Mylist() With {
.Pname = xlView.Rows(x).Cells(selcol).Value,
.Rid = rand.Next()
})
x += 1
Loop
plist.Sort()
x = 0
Do While x < xlView.Rows.Count
xlView.Rows(x).Cells(selcol).Value = plist.ElementAt(x).Pname
x += 1
Loop
xlView.Update()
plist.Clear()
I'm open to any changes to code, as long as it achieves the same result.
Here is the simpler version. Pass the column index will do like Call SortSingleColum(0)
Private Sub SortSingleColumn(x As Integer)
Dim DataCollection As New List(Of String)
For i = 0 To dgvImport.RowCount - 2
DataCollection.Add(dgvImport.Item(x, i).Value)
Next
Dim t As Integer = 0
For Each item As String In DataCollection.OrderBy(Function(z) z.ToString)
dgvImport.Item(x, t).Value = item
t = t + 1
Next
End Sub

How to find blank value from all member of class in vb.net

I have third party object which contain so many member with integer, string and Boolean. I want to update that record whose value is not null or blank
You can use reflection to achieve what you want:
Sub Main()
Dim obj As Test = new Test()
Dim type As Type = GetType(Test)
Dim info As PropertyInfo() = type.GetProperties()
For Each propertyInfo As PropertyInfo In info
Dim value As String = propertyInfo.GetValue(obj)
If propertyInfo.PropertyType = GetType(String) And String.IsNullOrEmpty(value)
' empty value for this string property
End If
Next
End Sub
public Class Test
Public Property Test As String
End Class

Should I use two methods with String and Integer,or use TypeOf?

We have a series of collections of objects that all have two fields for sure, an integer "key" and a string "name". We have methods that return a particular instance based on the name or key...
Public ReadOnly Property Inflations(ByVal K as String) As InflationRow
' look for K in the names
End Property
Public ReadOnly Property Inflations(ByVal K as Integer) As InflationRow
' look for K in the keys
End Property
COM interop has the interesting side effect that only the first method with a given name is exported. So we added this...
Public ReadOnly Property Inflations(ByVal K as Object) As InflationRow
Return Inflations(K)
End Property
This leads to some confusion when reading the code, and multiple lines doing the same thing. So what if I replace all of this with...
Public ReadOnly Property Inflations(ByVal K as Object) As InflationRow
If TypeOf K Is String then
'do a string lookup on name
else
'try it on the key
end if
End Property
This does the same thing in the end, but seems much easier to read and keeps all the code in the same place. But...
Most of the calls into this code doesn't come from COM, but our own code. Will many calls to TypeOf in our .net code be significantly slower than allowing the runtime to make this decision through polymorphism? I really don't know enough about the runtime to even guess.
Test it and see! :-)
Option Strict On
Module Module1
Sub Main()
Dim irc As New InflationRowCollection
For i As Integer = 0 To 4999
irc.InflationList.Add(New InflationRow With {.IntProperty = i, .StrProperty = i.ToString})
Next i
Dim t1 As Date = Now
For i As Integer = 0 To 4999
Dim ir1 As InflationRow = irc.Inflations(i)
Dim ir2 As InflationRow = irc.Inflations(i.ToString)
Next i
Dim t2 As Date = Now
For i As Integer = 0 To 4999
Dim ir1 As InflationRow = irc.InflationsObj(i)
Dim ir2 As InflationRow = irc.InflationsObj(i.ToString)
Next i
Dim t3 As Date = Now
Console.WriteLine("Typed property: " & (t2 - t1).TotalSeconds & " sec" & vbCrLf & "Object property: " & (t3 - t2).TotalSeconds & " sec")
Console.ReadKey()
End Sub
End Module
Class InflationRow
Property IntProperty As Integer
Property StrProperty As String
End Class
Class InflationRowCollection
Property InflationList As New List(Of InflationRow)
ReadOnly Property InflationsObj(o As Object) As InflationRow 'use different name for testing, so we can compare
Get
If TypeOf o Is String Then
Return Inflations(DirectCast(o, String))
ElseIf TypeOf o Is Integer Then
Return Inflations(DirectCast(o, Integer))
Else
Throw New ArgumentException
End If
End Get
End Property
ReadOnly Property Inflations(k As String) As InflationRow
Get
For Each ir As InflationRow In InflationList
If ir.StrProperty = k Then Return ir
Next
Return Nothing
End Get
End Property
ReadOnly Property Inflations(k As Integer) As InflationRow
Get
For Each ir As InflationRow In InflationList
If ir.IntProperty = k Then Return ir
Next
Return Nothing
End Get
End Property
End Class

Different Results using Parallel foreach everytime Excel Worksheet is read

Imports System.IO
Imports System.Threading
Imports System.Threading.Tasks
Imports System.Collections.Concurrent
Imports Excel = Microsoft.Office.Interop.Excel
Public Class TestCarDatas
Public Property RowID As Integer
Public Property ModelYear As Integer
Public Property VehMfcName As String
Public Property EmgVeh As Boolean
End Class
Module ExcelParallelDataGather2
Public Const ExcelVehDataPath As String = "D:\Users\Dell\Desktop"
Public rwl As New System.Threading.ReaderWriterLock()
Public rwl_writes As Integer = 0
Public FullTestVehData As New List(Of TestCarDatas)()
Public x1App As New Excel.Application
Public x1Workbook As Excel.Workbook
Public x1Worksheet1 As Excel.Worksheet
Public x1WkshtLrow As Integer
Sub main()
x1App.Visible = False
ErrorNotify = False
Console.WriteLine("Excel Parallel foreach operation program....")
Dim cki As ConsoleKeyInfo
x1Workbook = x1App.Workbooks.Open(Path.Combine(ExcelVehDataPath, "TestCarDatabase2014.xls"), , True)
x1Worksheet1 = x1Workbook.Sheets(1)
Do
Console.WriteLine("Press escape key to exit, 'a' key to reiterate, 'c' key to clear console")
cki = Console.ReadKey()
If Chr(cki.Key).ToString = "A" Then
Console.WriteLine("--> Processing...")
FullTestVehData.Clear()
rwl_writes = 0
Parallel.ForEach(Partitioner.Create(11, x1WkshtLrow + 1), _
Function()
' Initialize the local states
Return New List(Of TestCarDatas)()
End Function, _
Function(partrange, loopState, localState)
' Accumulate the thread-local computations in the loop body
localState = populateCardata(x1Worksheet1, partrange.Item1, partrange.Item2)
Return (localState)
End Function, _
Sub(finalstate)
' Combine all local states
Try
rwl.AcquireWriterLock(Timeout.Infinite)
Try
' It is safe for this thread to read or write
' from the shared resource in this block
FullTestVehData.AddRange(finalstate)
Interlocked.Increment(rwl_writes)
Finally
' Ensure that the lock is released.
rwl.ReleaseWriterLock()
End Try
Catch ex As ApplicationException
' The writer lock request timed out.
End Try
End Sub)
End If
If Chr(cki.Key).ToString = "C" Then
Console.Clear()
Console.WriteLine("Excel Parallel foreach operation program....")
End If
If Chr(cki.Key).ToString <> "A" And Chr(cki.Key).ToString <> "C" And _
cki.Key <> ConsoleKey.Escape Then
Console.WriteLine("")
Console.WriteLine("Invalid response via key press")
End If
Loop While (cki.Key <> ConsoleKey.Escape)
End Sub
Friend Function populateCardata(ByVal WksheetObj As Excel.Worksheet, ByVal rngStart As Integer, _
ByVal rngStop As Integer) As List(Of TestCarDatas)
Dim wkrng(12) As String
Dim PartVehData As New List(Of TestCarDatas)
PartVehData.Clear()
For i As Integer = rngStart To rngStop - 1
Dim data As New TestCarDatas
For j As Integer = 0 To 12
wkrng(j) = WksheetObj.Cells(i, j + 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
Next
With data
.RowID = i
.ModelYear = WksheetObj.Range(wkrng(0)).Value2
.VehMfcName = WksheetObj.Range(wkrng(1)).Value2
If WksheetObj.Range(wkrng(11)).Value2 = "Y" Then
.EmgVeh = True
Else
.EmgVeh = False
End If
End With
PartVehData.Add(data)
Next
Return PartVehData
End Function
End Module
I am trying to get the Excel Worksheet data using parallel foreach and range Partitioner, creating lists in thread local storage and finally adding them using thread safe methods like synclock or reader-writer locks
Rows from 11 to last row in worksheet are to be read and populated in a List(of T)
I observe following when I execute above code
When rows in worksheet are greater(example >2000), this code works as expected everytime
When rows in worksheet are less, this code returns partial list during first few iteration (data from some of the partitioner ranges are lost). If I re-iterate it (pressing key 'a') multiple times, then sometimes it returns expected results (final list count = no. of excel rows required to be read)
Why this phenomenon is observed?
What is the solution using parallel foreach, if I need correct results during first run/iteration irrespective of no. of rows in worksheet?

Extend Collections Class VBA

I have created a sort function to allow a collection of instances of a custom object to be sorted based on one of the objects properties. Is it possible to extend the existing collections class in VBA? I do not believe inheritance is supported in VBA, so I am not sure how to go about this in the proper way. I could just create a new module and place the function in that module, but that doesn't seem like the best way of doing it.
Thanks for the responses. I ended up creating my own class which extends the Collections class in VBA. Below is the code if anyone is interested.
'Custom collections class is based on the Collections class, this class extendes that
'functionallity so that the sort method for a collection of objects is part of
'the class.
'One note on this class is that in order to make this work in VBA, the Attribute method has to be added
'manually. To do this, create the class, then export it out of the project. Open in a text editor and
'add this line Attribute Item.VB_UserMemId = 0 under the Item() function and this line
'Attribute NewEnum.VB_UserMemId = -4 under the NewEnum() function. Save and import back into project.
'This allows the Procedure Attribute to be recognized.
Option Explicit
Private pCollection As Collection
Private Sub Class_Initialize()
Set pCollection = New Collection
End Sub
Private Sub Class_Terminate()
Set pCollection = Nothing
End Sub
Function NewEnum() As IUnknown
Set NewEnum = pCollection.[_NewEnum]
End Function
Public Function Count() As Long
Count = pCollection.Count
End Function
Public Function item(key As Variant) As clsCustomCollection
item = pCollection(key)
End Function
'Implements a selection sort algorithm, could likely be improved, but meets the current need.
Public Sub SortByProperty(sortPropertyName As String, sortAscending As Boolean)
Dim item As Object
Dim i As Long
Dim j As Long
Dim minIndex As Long
Dim minValue As Variant
Dim testValue As Variant
Dim swapValues As Boolean
Dim sKey As String
For i = 1 To pCollection.Count - 1
Set item = pCollection(i)
minValue = CallByName(item, sortPropertyName, VbGet)
minIndex = i
For j = i + 1 To pCollection.Count
Set item = pCollection(j)
testValue = CallByName(item, sortPropertyName, VbGet)
If (sortAscending) Then
swapValues = (testValue < minValue)
Else
swapValues = (testValue > minValue)
End If
If (swapValues) Then
minValue = testValue
minIndex = j
End If
Set item = Nothing
Next j
If (minIndex <> i) Then
Set item = pCollection(minIndex)
pCollection.Remove minIndex
pCollection.Add item, , i
Set item = Nothing
End If
Set item = Nothing
Next i
End Sub
Public Sub Add(value As Variant, key As Variant)
pCollection.Add value, key
End Sub
Public Sub Remove(key As Variant)
pCollection.Remove key
End Sub
Public Sub Clear()
Set m_PrivateCollection = New Collection
End Sub
One popular option is to use an ADO disconnected recordset as a sort of hyperpowered collection/dictionary object, which has built-in support for Sort. Although you are using ADO, you don't need a database.
I would create a wrapper class that exposes the collection object's properties, substituting the sort function with your own.