Why can not grid cloned with childrens? The following error occurs on the line Grid1 = Markup.XamlReader.Load(xmlReader):
System.Windows.Markup.XamlParseException: no matching constructor
found on type System.Windows.Media.Imaging.WriteableBitmap.
What needs to be changed?
Private Sub pelespausti(sender As Object, e As MouseButtonEventArgs) Handles Grid1.MouseDown
If e.LeftButton = MouseButtonState.Pressed Then
If im IsNot Nothing Then
If e.GetPosition(im).X >= im.Margin.Left AndAlso e.GetPosition(im).X < im.ActualWidth AndAlso
e.GetPosition(im).Y >= im.Margin.Top AndAlso e.GetPosition(im).Y < im.ActualHeight Then
'CType(bi.PixelWidth / 8, Integer)
Dim pix As PixelFormat = PixelFormats.Rgba64
Array.Resize(Of Byte)(pixels2, bi.PixelWidth * bi.PixelHeight * Math.Ceiling(pix.BitsPerPixel / 8))
colors = New List(Of System.Windows.Media.Color) From {System.Windows.Media.Colors.Transparent}
palete = New BitmapPalette(colors)
bi2 = BitmapSource.Create(bi.PixelWidth, bi.PixelHeight, 96, 96, pix, palete, pixels2, Math.Ceiling(bi.PixelWidth * pix.BitsPerPixel / 8))
o = New FormatConvertedBitmap(bi2, pix, palete, 100)
o2 = New FormatConvertedBitmap(bi, o.Format, palete, 100)
Dim pixelsp(Math.Ceiling(o2.Format.BitsPerPixel / 8)) As Byte
Dim pixelsp2(Math.Ceiling(o2.Format.BitsPerPixel / 8)) As Byte
o2.CopyPixels(New Int32Rect(e.GetPosition(im).X, e.GetPosition(im).Y, 1, 1), pixelsp, Math.Ceiling(o2.Format.BitsPerPixel / 8), 0) 'klaida
ras = New WriteableBitmap(o)
'Me.Title = Color.FromArgb(pixelsp(0), pixelsp(1), pixelsp(2), pixelsp(3)).R
Dim m As Boolean = True
For x = 0 To o2.PixelWidth - 1
For y = 0 To o2.PixelHeight - 1
o2.CopyPixels(New Int32Rect(x, y, 1, 1), pixelsp2, Math.Ceiling(o2.Format.BitsPerPixel / 8), 0)
For k = 0 To pixelsp.GetUpperBound(0)
If Not pixelsp(k) = pixelsp2(k) Then
m = False : Exit For
End If
Next
If m = True Then
ras.WritePixels(New Int32Rect(x, y, 1, 1), pixelsp2, Math.Ceiling(o.Format.BitsPerPixel / 8), 0)
Else
m = True
End If
Next
Next
im.Source = ras
Me.Title = "komp"
End If
End If
Dim objXaml As String = Markup.XamlWriter.Save(Grid1)
Dim StringReader As StringReader = New StringReader(objXaml)
Dim xmlReader As Xml.XmlReader = Xml.XmlReader.Create(StringReader)
Grid1 = Markup.XamlReader.Load(xmlReader)'here exception
End If
End Sub
Related
i am sort of novice with VBA. i am trying to work with 2 listboxes, listbox1 (.lstdatabase) and listbox2 (.lstdatabase1). what i am trying to do is, when i click update cost button, selected rows from listbox1 (.lstdatabse) transfer to listbox2 (.lstdatabase1). while doing this it only transfers column 1 to 4 from listbox1 as required.
I have manage to work above by suing codes. Now, I am struggling to populate listbox2 (.lstdatabase1) column 5 (this value is from worksheet (Cost)) based on value reference to column 4 in listbox2 (.lstdatabase1).
Codes I have as below,
Private Sub cmdcostupdates_Click()
With UserForm1.lstdatabase1
Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("cost")
.ColumnCount = 10
.ColumnHeads = True
.ColumnWidths = "40,60,60,60,60,100,100,250,80,80"
Dim i As Integer
For i = 0 To UserForm3.lstDatabase.ListCount - 1
If UserForm3.lstDatabase.Selected(i) = True Then
UserForm1.lstdatabase1.AddItem
UserForm1.lstdatabase1.Column(0, (UserForm1.lstdatabase1.ListCount - 1)) = UserForm3.lstDatabase.Column(0, i)
UserForm1.lstdatabase1.Column(1, (UserForm1.lstdatabase1.ListCount - 1)) = UserForm3.lstDatabase.Column(1, i)
UserForm1.lstdatabase1.Column(2, (UserForm1.lstdatabase1.ListCount - 1)) = UserForm3.lstDatabase.Column(2, i)
UserForm1.lstdatabase1.Column(3, (UserForm1.lstdatabase1.ListCount - 1)) = UserForm3.lstDatabase.Column(3, i)
UserForm1.lstdatabase1.Column(4, (UserForm1.lstdatabase1.ListCount - 1)) = UserForm3.lstDatabase.Column(4, i)
UserForm1.lstdatabase1.Column(5, (UserForm1.lstdatabase1.ListCount - 1)) = Application.WorksheetFunction.VLookup(.List(3, i), Sheets("sh").Range("A1:G1000"), 7, False)
Can someone help to correct code for vlookup? below code gives me error.
UserForm1.lstdatabase1.Column(5, (UserForm1.lstdatabase1.ListCount - 1)) = Application.WorksheetFunction.VLookup(.List(3, i), Sheets("sh").Range("A1:G1000"), 7, False)
Found the code,
Private Sub cmdcostupdates_Click()
Dim i As Long, n As Long, f, f1 As Range
r As Rang
With UserForm1.lstdatabase1
.ColumnCount = 10
.ColumnHeads = True
.ColumnWidths = "40; 60; 60; 60; 200; 100; 100; 250; 80; 80"
For i = 0 To UserForm3.lstDatabase.ListCount - 1
If UserForm3.lstDatabase.Selected(i) = True Then
.AddItem
n = .ListCount - 1
.Column(0, n) = UserForm3.lstDatabase.Column(0, i)
.Column(1, n) = UserForm3.lstDatabase.Column(1, i)
.Column(2, n) = UserForm3.lstDatabase.Column(2, i)
.Column(3, n) = UserForm3.lstDatabase.Column(3, i)
.Column(4, n) = UserForm3.lstDatabase.Column(5, i)
Set f = Sheets("cost").Range("A4:I400").Find(.Column(4, n), , xlValues, xlWhole)
Set f1 = Sheets("cost1").Range("A4:I400").Find(.Column(4, n), , xlValues, xlWhole)
Set r = Sheets("cost2").Range("A4:I400").Find(.Column(4, n), , xlValues, xlWhole)
If Not f Is Nothing Then
.Column(5, n) = Sheets("cost").Range("I" & f.Row)
End If
If Not f1 Is Nothing Then
.Column(6, n) = Sheets("cost1").Range("I" & f1.Row)
End If
If Not r Is Nothing Then
.Column(7, n) = Sheets("cost2").Range("I" & r.Row)
End If
End If
Next i
UserForm1.Show
End With
End Sub
I am doing my homework but stuck on a part. Problem is, How can i populate seat number in array of controls(labels) using database. I already created labels and a class to retrieve all rows from database but how can i apply it in main form and populate labels.
--------------------------Class---------------------------------------
Public Shared Function getOneRow(PK As Integer) As datMovieTimes
Dim returnRow As New datMovieTimes(0)
Dim connDB As New SqlConnection
connDB.ConnectionString = Conn.getConnectionString
Dim command As New SqlCommand
command.Connection = connDB
command.CommandType = CommandType.Text
command.CommandText = SQLStatements.SELECT_1_BY_ID
command.Parameters.AddWithValue("#Key", PK)
Try
connDB.Open()
Dim dR As IDataReader = command.ExecuteReader
If dR.Read() Then
returnRow.showingID = PK
If Not IsDBNull(dR(Fields.movieID)) Then returnRow.movieID = dR(Fields.movieID)
If Not IsDBNull(dR(Fields.dateTime)) Then returnRow.dateTime = dR(Fields.dateTime)
If Not IsDBNull(dR(Fields.isActive)) Then returnRow.isActive = dR(Fields.isActive)
End If
Catch ex As Exception
Console.WriteLine(Err.Description)
End Try
Return returnRow
End Function
Public Shared Function getAllRows() As Generic.List(Of datMovieTimes)
Dim returnRows As New Generic.List(Of datMovieTimes)
Dim connDB As New SqlConnection
connDB.ConnectionString = Conn.getConnectionString
Dim command As New SqlCommand
command.Connection = connDB
command.CommandType = CommandType.Text
command.CommandText = SQLStatements.SELECT_ALL
Try
connDB.Open()
Dim dR As IDataReader = command.ExecuteReader
Do While dR.Read()
Dim Row As New datMovieTimes(0)
If Not IsDBNull(dR(Fields.showingID)) Then Row.showingID = dR(Fields.showingID)
If Not IsDBNull(dR(Fields.movieID)) Then Row.movieID = dR(Fields.movieID)
If Not IsDBNull(dR(Fields.dateTime)) Then Row.dateTime = dR(Fields.dateTime)
If Not IsDBNull(dR(Fields.isActive)) Then Row.isActive = dR(Fields.isActive)
returnRows.Add(Row)
Loop
Catch ex As Exception
Console.WriteLine(Err.Description)
End Try
Return returnRows
End Function
-----------------------------main form-----------------------------------------
Public Sub createSeat()
Dim S1 As Label
For X As Integer = 1 To _MAX_X
For Y As Integer = 1 To _MAX_Y
S1 = New Label
S1.Height = 25
S1.Width = 25
S1.BackColor = Color.LightGreen
S1.Top = 100 + (X - 1) * (S1.Height + 5)
S1.Left = 200 + (Y - 1) * (S1.Width + 5)
S1.TextAlign = ContentAlignment.MiddleCenter
S1.Text = Y.ToString
AddHandler S1.Click, AddressOf GenericLabel_Click
Me.Controls.Add(S1)
_SeatArray(X, Y) = S1
Next
Next
For X As Integer = 0 To 9
_AlphaLabel(X) = New Label
_AlphaLabel(X).Height = 25
_AlphaLabel(X).Width = 25
_AlphaLabel(X).BackColor = Color.Transparent
_AlphaLabel(X).Top = 130 + (X - 1) * (_AlphaLabel(X).Height + 6)
_AlphaLabel(X).Left = 170
_AlphaLabel(X).Text = _AlphaName(X)
Me.Controls.Add(_AlphaLabel(X))
Next
End Sub
Private Sub GenericLabel_Click(sender As Object, e As EventArgs)
Dim L As New Label
L = DirectCast(sender, Label)
If L.BackColor = Color.LightGreen Then
L.BackColor = Color.Orange
clickLess -= 1
ElseIf L.BackColor = Color.Orange Then
L.BackColor = Color.LightGreen
clickLess += 1
End If
clickCount += 1
Me.lblRemainingCount.Text = clickLess.ToString
Me.nudTicketsCount.Value = clickCount
If clickLess <= 0 Then
MsgBox("No more seats left.", MsgBoxStyle.OkOnly, "House Full")
End If
End Sub
Database pic
When creating labels, insert one more line:
S1.Name = "MyLabel" & X & Y
When accessing the label:
Dim MyCurrentLabel as Label
MyCurrentLabel = CType("MyLabel" & X & Y, Label)
Then you can do things with the current label:
MyCurrentLabel.Text = "Hello World"
current image
Now it is something like this, so it want to change the colour to red if it is paid according to database.
Thanks
I found the answer, sorry i forgot to mention it because i was busy in completing the project
----------------------Seat creation----------------------------------------
Public Sub createSeat()
Dim S1 As Label
Dim numValue As Integer = 1
For X As Integer = 1 To _MAX_X
For Y As Integer = 1 To _MAX_Y
S1 = New Label
S1.Height = 25
S1.Width = 25
S1.BackColor = Color.LightGreen
S1.Top = 180 + (X - 1) * (S1.Height + 5)
S1.Left = 200 + (Y - 1) * (S1.Width + 5)
S1.TextAlign = ContentAlignment.MiddleCenter
S1.Text = Y.ToString
' S1.Text = numValue
S1.Name = "Label" & numValue
AddHandler S1.Click, AddressOf GenericLabel_Click
Me.Controls.Add(S1)
_SeatArray(X, Y) = S1
numValue += 1
Next
Next
For X As Integer = 0 To 9
_AlphaLabel(X) = New Label
_AlphaLabel(X).Height = 25
_AlphaLabel(X).Width = 25
_AlphaLabel(X).BackColor = Color.Transparent
_AlphaLabel(X).Top = 210 + (X - 1) * (_AlphaLabel(X).Height + 6)
_AlphaLabel(X).Left = 170
_AlphaLabel(X).Text = _AlphaName(X)
Me.Controls.Add(_AlphaLabel(X))
Next
End Sub
-------------------------------populate seat number----------------------------------
Public Sub populateSeatNumber()
Dim connectionString As String = DBL.Conn.getConnectionString
Dim connection As New SqlConnection(connectionString)
connection.Open()
Dim selectStatement As String = "SELECT * FROM datTicketsSold"
Dim selectCommand As New SqlCommand(selectStatement, connection)
Dim daSoldTickets As New SqlDataAdapter(selectCommand)
Dim dsSoldTickets As DataSet = New DataSet
daSoldTickets.Fill(dsSoldTickets, "datTicketsSold")
connection.Close()
Dim dtTickets As DataTable = dsSoldTickets.Tables("datTicketsSold")
Dim row As DataRow
For Each row In dtTickets.Rows
If row(3) = True Then
CType(Controls("Label" & row(2)), Label).BackColor = Color.Red
redCounter += 1
Else
CType(Controls("Label" & row(2)), Label).BackColor = Color.Yellow
yellowCounter += 1
End If
Next
Me.lblReservedCount.Text = yellowCounter.ToString
Me.lblSoldCount.Text = redCounter.ToString
End Sub
Thanks everyone
I have an array filled with zeros and ones like that:
...0001100011110000110011111100111...
it always starts with zeros and ends with ones.
I have to find the index of the beginning of the first row of ones, that is longer than the following row of zeros. The bold one above.
I have already set a with the index of the first one, and set b with the index of the last zero.
k = 0
Do While array(k) = 0
k = k + 1
Loop
a = k
l = endOfArray
Do While array(l) = 1
l = l - 1
Loop
b = l
How can i go on?
you can use this function:
Option Explicit
Function GetOnes(inputStrng As String) As String
Dim i As Long
Dim zeros As Variant, ones As Variant
zeros = Split(WorksheetFunction.Trim(Replace(inputStrng, "1", " ")))
ones = Split(WorksheetFunction.Trim(Replace(inputStrng, "0", " ")))
For i = 0 To UBound(ones)
If Len(ones(i)) > Len(zeros(i)) Then
GetOnes = ones(i)
Exit For
End If
Next i
End Function
to be exploited as follows:
Sub main()
MsgBox "the first 'ones' sequence longer then subsequent 'zero' sequence is:" & vbCrLf & vbCrLf & vbTab & GetOnes("0001100000111001111111")
End Sub
Not fully tested, but something like this. SORRY, I've coded > previous to, i'll change later.
Sub Testsing()
Dim strInput As String
Dim arrSplitInput() As String
Dim intLoop As Integer
Dim intZeroes As Integer
Dim intIndex As Integer
strInput = "0001100000111001111111"
arrSplitInput = Split(strInput, "0")
For intLoop = 0 To UBound(arrSplitInput)
If arrSplitInput(intLoop) = "" Then
intZeroes = intZeroes + 1
Else
If intIndex > 0 Then intZeroes = intZeroes + 1
intIndex = intIndex + intZeroes
If Len(arrSplitInput(intLoop)) > intZeroes Then
Debug.Print Mid(strInput, intIndex - 1, Len(arrSplitInput(intLoop)))
Stop
Else
intIndex = intIndex + Len(arrSplitInput(intLoop)) + 1
End If
intZeroes = 0
End If
Next intLoop
End Sub
Answer is overkill for a simple array job, but just a taste of OO VBA to see what you could get if you needed to extend the information required from the block of 1s.
Put in a Class module (Alt-I-C) named NumBlock
Option Explicit
Private pLength As Long
Private pIndex As Long
Public Property Get Length() As Long
Length = pLength
End Property
Public Property Let Length(val As Long)
pLength = val
End Property
Public Property Get Index() As Long
Index = pIndex
End Property
Public Property Let Index(val As Long)
pIndex = val
End Property
Regular module:
Option Explicit
Public Function getIndexOfLongerOnes(arr As Variant) As NumBlock
If InStr(1, TypeName(arr), "()", vbTextCompare) < 1 Then
Err.Raise vbObjectError + 888, , "The argument was not an array!"
End If
Dim switched As Boolean
Dim a As Long, z As Long
Dim ones As NumBlock, zeroes As NumBlock
a = LBound(arr)
z = UBound(arr)
switched = True
Set ones = New NumBlock
Set zeroes = New NumBlock
Dim i As Long
For i = a To z
If i > a Then
If arr(i) <> arr(i - 1) Then
switched = True
Else
switched = False
End If
End If
If arr(i) = 1 Then
If switched Then
If ones.Length > zeroes.Length Then
Set getIndexOfLongerOnes = ones
Exit Function
End If
Set ones = New NumBlock
ones.Length = 1
ones.Index = i
Else
ones.Length = ones.Length + 1
End If
Else
If switched Then
Set zeroes = New NumBlock
zeroes.Length = 1
zeroes.Index = i
Else
zeroes.Length = zeroes.Length + 1
End If
End If
Next i
End Function
Public Sub test()
On Error GoTo handler
Dim testArr As Variant
Dim block As NumBlock
testArr = Array(0, 0, 0, 1, 1, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1)
Set block = getIndexOfLongerOnes(testArr)
MsgBox "Index: " & block.Index & vbNewLine & "Length: " & block.Length
Exit Sub
handler:
MsgBox Err.Description
End Sub
A simpler array job:
Public Function getArrIndex(arr As Variant) As Long
Dim switched As Boolean
Dim a As Long, z As Long, currOnesIndex As Long, currZeroesIndex As Long, currOnesLength As Long, currZeroesLength As Long
getArrIndex = -1 'default to -1 as not found qualifying set of ones
a = LBound(arr)
z = UBound(arr)
switched = True
Dim i As Long
For i = a To z
If i > a Then
If arr(i) <> arr(i - 1) Then
switched = True
Else
switched = False
End If
End If
If arr(i) = 1 Then
If switched Then
If currOnesLength > currZeroesLength Then
getArrIndex = currOnesIndex
Exit Function
End If
currOnesLength = 1
currOnesIndex = i
Else
currOnesLength = currOnesLength + 1
End If
Else
If switched Then
currZeroesLength = 1
currZeroesIndex = i
Else
currZeroesLength = currZeroesLength + 1
End If
End If
Next i
End Function
first of all, i'd like to say, i've sarched thorugh the net, but i haven't run into such a thing. i've seen collection of collections, or array of arrays, but not a collection of array.
what i want to do is, to collect ID's in collections for each District. Finally, i will join the values in the collections with Join function and ";" as delimiter, and then print them in a range of 4 column as a lookup list, for each class. For example;
Class2(0) will include 54020 and 30734, class2(1) will include 58618, class1(4) will include none, class3(7) will include 35516,34781 and 56874, and so on.
i want to loop through column C and put a select case statment to check the class and then assign the values to collections
Sub dict_coll()
Dim class1() As New Collection
Dim class2() As New Collection
Dim class3() As New Collection
Dim class4() As New Collection
Dim dict As New Scripting.Dictionary
Set dRange = range(range("a2"), range("a2").End(xlDown))
i = 0
For Each d In dRange
If Not dict.Exists(d.Value) Then
dict.Add key:=d.Value, item:=i
i = i + 1
End If
Next d
Set cRange = range(range("c2"), range("c2").End(xlDown))
For Each c In cRange
Select Case c.Value
Case "class1"
class1(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case "class2"
class2(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case "class3"
class3(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case Else
class4(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
End Select
Next c
End Sub
and what i want to see is as foloowing:
is there any easier and proper way of what i wanna do? any help wil be appreciated.
thanks
I didnt see that sb variable defined in your code.
Anyway, for me I see a case of straightforward arrays: There is fixed dimension of classes so it good enough for me. Furthermore, you can print back to worksheet so easily.
Public Sub test()
Const strPrefix = "class"
Dim districtRange As Range, outputRange As Range, r As Range
Dim arr() As String
Dim i As Long, j As Long, x As Long, y As Long
Dim district As String, str As String, idVal As String
Dim arr2 As Variant
Application.ScreenUpdating = False
ReDim arr(1 To 5, 1 To 1)
arr(1, 1) = "District"
arr(2, 1) = "Class 1"
arr(3, 1) = "Class 2"
arr(4, 1) = "Class 3"
arr(5, 1) = "Class 4"
Set districtRange = Range(Range("A2"), Range("C2").End(xlDown))
arr2 = districtRange.Value
For x = LBound(arr2, 1) To UBound(arr2, 1)
district = arr2(x, 1)
i = Val(Mid(arr2(x, 3), Len(strPrefix) + 1))
idVal = arr2(x, 2)
j = inArray(arr, district, 1) 'returns -1 if not found
If j >= 0 Then
arr(i + 1, j) = IIf(arr(i + 1, j) = "", idVal, arr(i + 1, j) & ";" & idVal)
Else
ReDim Preserve arr(1 To 5, 1 To UBound(arr, 2) + 1)
arr(1, UBound(arr, 2)) = district
arr(i + 1, UBound(arr, 2)) = idVal
End If
Next x
Set outputRange = Range("E1")
outputRange.Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.Transpose(arr)
outputRange.Sort Key1:=Range("E1"), Header:=xlYes, Order1:=xlAscending
Application.ScreenUpdating = True
End Sub
Public Function inArray(arr As Variant, k As String, Optional rowNum As Long, Optional colNum As Long) As Long
Dim i As Long, j As Long
inArray = -1
If rowNum Then
For i = LBound(arr, 2) To UBound(arr, 2)
If arr(rowNum, i) = k Then
inArray = i
Exit Function
End If
Next i
Else
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, colNum) = k Then
inArray = i
Exit Function
End If
Next i
End If
End Function
by the way, i've found another solution, usinf both dictionary and 3-dimension array.
Sub test()
Dim Blg As New Scripting.Dictionary
Dim Sgm As New Scripting.Dictionary
Dim Siciller() As String
ReDim Siciller(0 To 23, 0 To 3, 0 To 5)
Set alanBolge = range(range("a2"), range("a2").End(xlDown))
Set alanSegment = range(range("c2"), range("c2").End(xlDown))
i = 0
For Each d In alanBolge
If Not Blg.Exists(d.Value) Then
Blg.Add Key:=d.Value, item:=i
i = i + 1
End If
Next d
k = 0
For Each d In alanSegment
If Not Sgm.Exists(d.Value) Then
Sgm.Add Key:=d.Value, item:=k
k = k + 1
End If
Next d
'data reading
For Each d In alanBolge
Siciller(Blg(d.Value), Sgm(d.Offset(0, 2).Value), dolusay(Siciller, Blg(d.Value), Sgm(d.Offset(0, 2).Value)) + 1) = d.Offset(0, 1).Value
Next d
'output
For x = 1 To 4
For y = 1 To 24
Set h = Cells(1 + y, 5 + x)
h.Select
h.Value = sonucgetir(Siciller, Blg(h.Offset(0, -x).Value), Sgm(h.Offset(-y, 0).Value))
Next y
Next x
End Sub
Public Function dolusay(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As Integer
Dim count As Integer
count = 0
For j = 0 To UBound(data, 3) - 1
If Len(data(i1, i2, j)) > 0 Then
count = count + 1
End If
Next
dolusay = count
End Function
Public Function sonucgetir(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As String
sonucgetir = ""
For i = 0 To UBound(data, 3)
If Len(data(i1, i2, i)) > 0 Then
x = data(i1, i2, i) & ";" & x
sonucgetir = Left(x, Len(x) - 1)
End If
Next i
End Function
I want to run the fetching of a Database into a background worker but it seems to be crashing without Visual Studio returning me an error in my code.
Here's the code in the DoWork:
Private Sub ITSM_Fetch_BW_DoWork(sender As Object, e As System.ComponentModel.DoWorkEventArgs) Handles ITSM_Fetch_BW.DoWork
Dim sql As String = "xxxx"
Dim ConnString As String = "DRIVER={AR System ODBC Driver};ARServer=xxxx;ARServerPort=xxxx;ARPrivateRpcSocket=xxxx;UID=xxxx;PWD=xxxx;ARAuthentication=;ARUseUnderscores=1;SERVER=NotTheServer"
Dim connection As New Odbc.OdbcConnection(ConnString)
connection.Open()
Dim ODBC_Command As New Odbc.OdbcCommand(sql, connection)
Dim ODBC_reader As Odbc.OdbcDataReader
'Load the Data into the local Memory
ODBC_reader = ODBC_Command.ExecuteReader
e.Result = ODBC_reader
ODBC_reader.Close()
End Sub
Private Sub ITSM_Fetch_BW_RunWorkerCompleted(sender As Object, e As RunWorkerCompletedEventArgs) Handles ITSM_Fetch_BW.RunWorkerCompleted
Data = New DataTable
Data.Load(e.Result)
Dim Count_ToDo(5) As String
Count_ToDo(0) = "Product_Name"
Count_ToDo(1) = "Status"
Count_ToDo(2) = "Language"
Count_ToDo(3) = "Assigned_Group"
Count_ToDo(4) = "Priority"
Count_ToDo(5) = "Company"
For Each Item As String In Count_ToDo
Dim i As Integer = 0
Dim ITEM_Count(0, 1) As String
For Each Ticket As DataRow In Data.Rows
'PART FOR THE CI
If IsDBNull(Ticket.Item(Item)) = False Then
Dim IsInIndex As Integer = -1
If i = 0 Then
ITEM_Count(0, 0) = Ticket.Item(Item)
ITEM_Count(0, 1) = 1
Else
For x As Integer = 0 To ITEM_Count.GetLength(0) - 1
If ITEM_Count(x, 0) = Ticket.Item(Item) Then
IsInIndex = x
End If
Next
If IsInIndex = -1 Then
Dim ITEM_Count_Temp(ITEM_Count.GetLength(0), ITEM_Count.GetLength(0)) As String
ITEM_Count_Temp = ITEM_Count
ReDim ITEM_Count(ITEM_Count.GetLength(0), 1)
For x As Integer = 0 To ITEM_Count_Temp.GetLength(0) - 1
For y As Integer = 0 To ITEM_Count_Temp.GetLength(1) - 1
ITEM_Count(x, y) = ITEM_Count_Temp(x, y)
Next
Next
ITEM_Count(ITEM_Count.GetLength(0) - 1, 0) = Ticket.Item(Item)
ITEM_Count(ITEM_Count.GetLength(0) - 1, 1) = 1
Else
ITEM_Count(IsInIndex, 1) = ITEM_Count(IsInIndex, 1) + 1
End If
End If
Else
'IF NULL
End If
i = i + 1
Next
'CI_COUNT FILLING
'ORDERING BY COUNT
Dim ITEM_obj = New List(Of obj)
Dim ITEM_ToObj As String = ""
Dim ITEMCount_ToObj As String = ""
For x As Integer = 0 To ITEM_Count.GetLength(0) - 1
ITEM_ToObj = ITEM_Count(x, 0)
ITEMCount_ToObj = ITEM_Count(x, 1)
ITEM_obj.Add(New obj(ITEM_ToObj, ITEMCount_ToObj))
Next
ITEM_obj = OrderItem(ITEM_obj)
Dim Item_Count_listview As ListViewItem
For Each Itemobj As obj In ITEM_obj
Dim Transfer_Array(2) As String
Transfer_Array(0) = Itemobj.Item
Transfer_Array(1) = Itemobj.Item_Count
Item_Count_listview = New ListViewItem(Transfer_Array)
Select Case Item
Case "Product_Name"
CI_Count_Table.Items.Add(Item_Count_listview)
Case "Status"
Status_Count_Table.Items.Add(Item_Count_listview)
Case "Language"
Language_Count_Table.Items.Add(Item_Count_listview)
Case "Assigned_Group"
AssignedGroup_Count_Table.Items.Add(Item_Count_listview)
Case "Priority"
Priority_Count_Table.Items.Add(Item_Count_listview)
Case "Company"
LOB_Count_Table.Items.Add(Item_Count_listview)
Case Else
MsgBox("No Category Of this type exist. Programming Issue. Item is: " & Item)
End Select
Next
Next
End Sub
What is not possible to run into a background worker like this?
regards,