i am new in Stackoverflow
i am doing a project for 4th stage college that is car counting and classification based on EmguCV and Vb.net now i've done coding car counting but i have a problem in classification that i don't know how to code a classification like how many heavy cars and light cars.
this is my code:
'MultipleObjectTrackingVB.sln
'frmMain.vb
'
'form components
'
'tableLayoutPanel
'btnOpenFile
'lblChosenFile
'imageBox
'txtInfo
'openFileDialog
'
'Emgu CV 3.1.0
Option Explicit On 'require explicit declaration of variables, this is NOT Python !!
Option Strict On 'restrict implicit data type conversions to only widening conversions
Imports Emgu.CV '
Imports Emgu.CV.CvEnum 'usual Emgu Cv imports
Imports Emgu.CV.Structure '
Imports Emgu.CV.UI '
Imports Emgu.CV.Util
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Class Form1
' member variables ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim SCALAR_BLACK As New MCvScalar(0.0, 0.0, 0.0)
Dim SCALAR_WHITE As New MCvScalar(255.0, 255.0, 255.0)
Dim SCALAR_BLUE As New MCvScalar(255.0, 0.0, 0.0)
Dim SCALAR_GREEN As New MCvScalar(0.0, 200.0, 0.0)
Dim SCALAR_RED As New MCvScalar(0.0, 0.0, 255.0)
Dim capVideo As Capture
Dim blnFormClosing As Boolean = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub Form1_FormClosing(sender As Object, e As FormClosingEventArgs) Handles MyBase.FormClosing
blnFormClosing = True
CvInvoke.DestroyAllWindows()
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub btnOpenFile_Click(sender As Object, e As EventArgs) Handles btnOpenFile.Click
Dim drChosenFile As DialogResult
drChosenFile = openFileDialog.ShowDialog() 'open file dialog
If (drChosenFile <> DialogResult.OK Or openFileDialog.FileName = "") Then 'if user chose Cancel or filename is blank . . .
lblChosenFile.Text = "file not chosen" 'show error message on label
Return 'and exit function
End If
Try
capVideo = New Capture(openFileDialog.FileName) 'attempt to open chosen video file
Catch ex As Exception 'catch error if unsuccessful
'show error via message box
MessageBox.Show("unable to read video file, error: " + ex.Message)
Return
End Try
lblChosenFile.Text = openFileDialog.FileName
If (capVideo Is Nothing) Then
txtInfo.AppendText("unable to read video file")
End If
If (capVideo.GetCaptureProperty(CapProp.FrameCount) < 2) Then 'check and make sure the video has at least 2 frames
txtInfo.AppendText("error: video file must have at least two frames")
End If
trackBlobsAndUpdateGUI()
End Sub
Sub trackBlobsAndUpdateGUI()
Dim imgFrame1 As Mat
Dim imgFrame2 As Mat
Dim blobs As New List(Of Blob)
Dim crossingLine(2) As Point
Dim carCount As Integer = 0
imgFrame1 = capVideo.QueryFrame()
imgFrame2 = capVideo.QueryFrame()
Dim horizontalLinePosition As Integer = CInt(Math.Round(CDbl(imgFrame1.Rows()) * 0.3))
crossingLine(0).X = 0
crossingLine(0).Y = horizontalLinePosition
crossingLine(1).X = imgFrame1.Cols() - 1
crossingLine(1).Y = horizontalLinePosition
Dim blnFirstFrame As Boolean = True
While (blnFormClosing = False)
Dim currentFrameBlobs As New List(Of Blob)
Dim imgFrame1Copy As Mat = imgFrame1.Clone()
Dim imgFrame2Copy As Mat = imgFrame2.Clone()
Dim imgDifference As New Mat(imgFrame1.Size, DepthType.Cv8U, 1)
Dim imgThresh As New Mat(imgFrame1.Size, DepthType.Cv8U, 1)
CvInvoke.CvtColor(imgFrame1Copy, imgFrame1Copy, ColorConversion.Bgr2Gray)
CvInvoke.CvtColor(imgFrame2Copy, imgFrame2Copy, ColorConversion.Bgr2Gray)
CvInvoke.GaussianBlur(imgFrame1Copy, imgFrame1Copy, New Size(5, 5), 0)
CvInvoke.GaussianBlur(imgFrame2Copy, imgFrame2Copy, New Size(5, 5), 0)
CvInvoke.AbsDiff(imgFrame1Copy, imgFrame2Copy, imgDifference)
CvInvoke.Threshold(imgDifference, imgThresh, 30, 255.0, ThresholdType.Binary)
CvInvoke.Imshow("imgThresh", imgThresh)
Dim structuringElement3x3 As Mat = CvInvoke.GetStructuringElement(ElementShape.Rectangle, New Size(3, 3), New Point(-1, -1))
Dim structuringElement5x5 As Mat = CvInvoke.GetStructuringElement(ElementShape.Rectangle, New Size(5, 5), New Point(-1, -1))
Dim structuringElement7x7 As Mat = CvInvoke.GetStructuringElement(ElementShape.Rectangle, New Size(7, 7), New Point(-1, -1))
Dim structuringElement9x9 As Mat = CvInvoke.GetStructuringElement(ElementShape.Rectangle, New Size(9, 9), New Point(-1, -1))
For i As Integer = 0 To 1
CvInvoke.Dilate(imgThresh, imgThresh, structuringElement5x5, New Point(-1, -1), 1, BorderType.Default, New MCvScalar(0, 0, 0))
CvInvoke.Dilate(imgThresh, imgThresh, structuringElement5x5, New Point(-1, -1), 1, BorderType.Default, New MCvScalar(0, 0, 0))
CvInvoke.Erode(imgThresh, imgThresh, structuringElement5x5, New Point(-1, -1), 1, BorderType.Default, New MCvScalar(0, 0, 0))
Next
Dim imgThreshCopy As Mat = imgThresh.Clone()
Dim contours As New VectorOfVectorOfPoint()
CvInvoke.FindContours(imgThreshCopy, contours, Nothing, RetrType.External, ChainApproxMethod.ChainApproxSimple)
'drawAndShowContours(imgThresh.Size(), contours, "imgContours")
Dim convexHulls As New VectorOfVectorOfPoint(contours.Size())
For i As Integer = 0 To contours.Size() - 1
CvInvoke.ConvexHull(contours(i), convexHulls(i))
Next
'drawAndShowContours(imgThresh.Size(), convexHulls, "imgConvexHulls")
For i As Integer = 0 To contours.Size() - 1
Dim possibleBlob As New Blob(convexHulls(i))
If (possibleBlob.intCurrentRectArea > 400 And
possibleBlob.dblCurrentAspectRatio > 0.2 And
possibleBlob.dblCurrentAspectRatio < 4.0 And
possibleBlob.currentBoundingRect.Width > 30 And
possibleBlob.currentBoundingRect.Height > 30 And
possibleBlob.dblCurrentDiagonalSize > 60.0 And
(CvInvoke.ContourArea(possibleBlob.currentContour) / possibleBlob.intCurrentRectArea) > 0.5) Then
currentFrameBlobs.Add(possibleBlob)
End If
Next
'drawAndShowContours(imgThresh.Size(), currentFrameBlobs, "imgCurrentFrameBlobs")
If (blnFirstFrame = True) Then
For Each currentFrameBlob As Blob In currentFrameBlobs
blobs.Add(currentFrameBlob)
Next
Else
matchCurrentFrameBlobsToExistingBlobs(blobs, currentFrameBlobs)
End If
'drawAndShowContours(imgThresh.Size(), blobs, "imgBlobs")
imgFrame2Copy = imgFrame2.Clone()
drawBlobInfoOnImage(blobs, imgFrame2Copy)
Dim atLeastOneBlobCrossedTheLine = checkIfBlobsCrossedTheLine(blobs, horizontalLinePosition, carCount)
If (atLeastOneBlobCrossedTheLine) Then
CvInvoke.Line(imgFrame2Copy, crossingLine(0), crossingLine(1), SCALAR_GREEN, 2)
Else
CvInvoke.Line(imgFrame2Copy, crossingLine(0), crossingLine(1), SCALAR_RED, 2)
End If
drawCarCountOnImage(carCount, imgFrame2Copy)
imageBox.Image = imgFrame2Copy
'now we prepare for the next iteration
currentFrameBlobs.Clear()
imgFrame1 = imgFrame2.Clone() 'move frame 1 up to where frame 2 is
If (capVideo.GetCaptureProperty(CapProp.PosFrames) + 1 < capVideo.GetCaptureProperty(CapProp.FrameCount)) Then 'if there is at least one more frame
imgFrame2 = capVideo.QueryFrame() 'get the next frame
Else 'else if there is not at least one more frame
txtInfo.AppendText("end of video") 'show end of video message
Exit While 'and jump out of while loop
End If
blnFirstFrame = False
Application.DoEvents()
End While
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub matchCurrentFrameBlobsToExistingBlobs(ByRef existingBlobs As List(Of Blob), ByRef currentFrameBlobs As List(Of Blob))
For Each existingBlob As Blob In existingBlobs
existingBlob.blnCurrentMatchFoundOrNewBlob = False
existingBlob.predictNextPosition()
Next
For Each currentFrameBlob As Blob In currentFrameBlobs
Dim intIndexOfLeastDistance As Integer = 0
Dim dblLeastDistance As Double = 1000000.0
For i As Integer = 0 To existingBlobs.Count() - 1
If (existingBlobs(i).blnStillBeingTracked = True) Then
Dim dblDistance As Double = distanceBetweenPoints(currentFrameBlob.centerPositions.Last(), existingBlobs(i).predictedNextPosition)
If (dblDistance < dblLeastDistance) Then
dblLeastDistance = dblDistance
intIndexOfLeastDistance = i
End If
End If
Next
If (dblLeastDistance < currentFrameBlob.dblCurrentDiagonalSize * 0.5) Then
addBlobToExistingBlobs(currentFrameBlob, existingBlobs, intIndexOfLeastDistance)
Else
addNewBlob(currentFrameBlob, existingBlobs)
End If
Next
For Each existingBlob As Blob In existingBlobs
If (existingBlob.blnCurrentMatchFoundOrNewBlob = False) Then
existingBlob.intNumOfConsecutiveFramesWithoutAMatch = existingBlob.intNumOfConsecutiveFramesWithoutAMatch + 1
End If
If (existingBlob.intNumOfConsecutiveFramesWithoutAMatch >= 5) Then
existingBlob.blnStillBeingTracked = False
End If
Next
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub addBlobToExistingBlobs(ByRef currentFrameBlob As Blob, ByRef existingBlobs As List(Of Blob), ByRef intIndex As Integer)
existingBlobs(intIndex).currentContour = currentFrameBlob.currentContour
existingBlobs(intIndex).currentBoundingRect = currentFrameBlob.currentBoundingRect
existingBlobs(intIndex).centerPositions.Add(currentFrameBlob.centerPositions.Last())
existingBlobs(intIndex).dblCurrentDiagonalSize = currentFrameBlob.dblCurrentDiagonalSize
existingBlobs(intIndex).dblCurrentAspectRatio = currentFrameBlob.dblCurrentAspectRatio
existingBlobs(intIndex).blnStillBeingTracked = True
existingBlobs(intIndex).blnCurrentMatchFoundOrNewBlob = True
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub addNewBlob(ByRef currentFrameBlob As Blob, ByRef existingBlobs As List(Of Blob))
currentFrameBlob.blnCurrentMatchFoundOrNewBlob = True
existingBlobs.Add(currentFrameBlob)
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function distanceBetweenPoints(point1 As Point, point2 As Point) As Double
Dim intX As Integer = Math.Abs(point1.X - point2.X)
Dim intY As Integer = Math.Abs(point1.Y - point2.Y)
Return Math.Sqrt((intX ^ 2) + (intY ^ 2))
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub drawAndShowContours(imageSize As Size, contours As VectorOfVectorOfPoint, strImageName As String)
Dim image As New Mat(imageSize, DepthType.Cv8U, 3)
CvInvoke.DrawContours(image, contours, -1, SCALAR_WHITE, -1)
CvInvoke.Imshow(strImageName, image)
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub drawAndShowContours(imageSize As Size, blobs As List(Of Blob), strImageName As String)
Dim image As New Mat(imageSize, DepthType.Cv8U, 3)
Dim contours As New VectorOfVectorOfPoint()
For Each blob As Blob In blobs
If (blob.blnStillBeingTracked = True) Then
contours.Push(blob.currentContour)
End If
Next
CvInvoke.DrawContours(image, contours, -1, SCALAR_WHITE, -1)
CvInvoke.Imshow(strImageName, image)
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function checkIfBlobsCrossedTheLine(ByRef blobs As List(Of Blob), ByRef horizontalLinePosition As Integer, ByRef carCount As Integer) As Boolean
Dim atLeastOneBlobCrossedTheLine As Boolean = False 'this will be the return value
For Each blob As Blob In blobs
If (blob.blnStillBeingTracked = True And blob.centerPositions.Count() >= 2) Then
Dim prevFrameIndex As Integer = blob.centerPositions.Count() - 2
Dim currFrameIndex As Integer = blob.centerPositions.Count() - 1
If (blob.centerPositions(prevFrameIndex).Y > horizontalLinePosition And blob.centerPositions(currFrameIndex).Y <= horizontalLinePosition) Then
carCount = carCount + 1
atLeastOneBlobCrossedTheLine = True
End If
End If
Next
Return (atLeastOneBlobCrossedTheLine)
End Function
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub drawBlobInfoOnImage(ByRef blobs As List(Of Blob), ByRef imgFrame2Copy As Mat)
For i As Integer = 0 To blobs.Count - 1
If (blobs(i).blnStillBeingTracked = True) Then
CvInvoke.Rectangle(imgFrame2Copy, blobs(i).currentBoundingRect, SCALAR_RED, 2)
Dim fontFace As FontFace = FontFace.HersheySimplex
Dim dblFontScale As Double = blobs(i).dblCurrentDiagonalSize / 60.0
Dim intFontThickness As Integer = CInt(Math.Round(dblFontScale * 1.0))
CvInvoke.PutText(imgFrame2Copy, i.ToString(), blobs(i).centerPositions.Last(), fontFace, dblFontScale, SCALAR_GREEN, intFontThickness)
End If
Next
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub drawCarCountOnImage(ByRef carCount As Integer, ByRef imgFrame2Copy As Mat)
Dim fontFace As FontFace = FontFace.HersheySimplex
Dim dblFontScale As Double = CDbl(imgFrame2Copy.Rows() * imgFrame2Copy.Cols()) / 300000.0
Dim intFontThickness As Integer = CInt(Math.Round(dblFontScale * 1.5))
Dim textSize As Size = getTextSize(carCount.ToString(), fontFace, dblFontScale, intFontThickness)
Dim bottomLeftTextPosition As New Point()
bottomLeftTextPosition.X = imgFrame2Copy.Cols - 1 - CInt(CDbl(textSize.Width) * 1.3)
bottomLeftTextPosition.Y = CInt(CDbl(textSize.Height) * 1.3)
CvInvoke.PutText(imgFrame2Copy, carCount.ToString(), bottomLeftTextPosition, fontFace, dblFontScale, SCALAR_GREEN, intFontThickness)
End Sub
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getTextSize(strText As String, intFontFace As Integer, dblFontScale As Double, intFontThickness As Integer) As Size
Dim textSize As New Size() 'this will be the return value
Dim intNumChars As Integer = strText.Count()
textSize.Width = 55 * intNumChars
textSize.Height = 65
Return (textSize)
End Function
Private Sub imageBox_Click(sender As Object, e As EventArgs) Handles imageBox.Click
End Sub
End Class
I got an issue with "casting" variants to defined objects.
At runtime my variant variable is of type "Variant/Object/Listbox", which i then want to set to a ListBox variable to route it as a parameter to another function (GetSelected) that requires a Listbox object.
But I get the error 13: types incompatible on command "Set lst = v".
Any ideas how to get it working?
Code:
Function GetEditableControlsValues(EditableControls As Collection) As Collection
'Gibt die Werte der editierbaren Felder zurück.
Dim v As Variant
Dim coll As New Collection
Dim lst As ListBox
For Each v In EditableControls
If TypeName(v) = "ListBox" Then
Set lst = v 'Fehler 13: Typen unverträglich. v zur Laufzeit: Variant/Object/Listbox.
coll.Add GetCollectionString(GetSelected(lst))
Else
coll.Add v.Value
End If
Next
End Function
This is what I have so far:
Imagine that you have a module with the following code in it:
Option Explicit
Public Sub TestMe()
Dim colInput As New Collection
Dim colResult As Collection
Dim lngCount As Long
Dim ufMyUf As UserForm
Set ufMyUf = UserForm1
Set colInput = GetListBoxObjects(ufMyUf)
For lngCount = 1 To colInput.Count
Debug.Print colInput(lngCount).Name
Next lngCount
End Sub
Function GetListBoxObjects(uf As UserForm) As Collection
Dim colResult As New Collection
Dim objObj As Object
Dim ctrCont As Control
For Each ctrCont In uf.Controls
If LCase(Left(ctrCont.Name, 7)) = "listbox" Then
Set objObj = ctrCont
colResult.Add objObj
End If
Next ctrCont
Set GetListBoxObjects = colResult
End Function
If you run TestMe, you would get a collection of the ListBox objects. Anyhow, I am not sure how do you pass them to the collection function, thus I have decided to iterate over the UserForm and thus to check all of the objects on it.
Cheers!
I had problems with casting controls myself and didn't find a general solution that I could use easy.
Eventually I found the way to do it: store as "Object" makes it easy to convert to whatever type the control actually is.
I tested (and use) it
The sub below shows that it works (here : 1 TextBox; 1 ListBox; 1 ComboBox; 1 CommandButton on a worksheet)
Sub Test_Casting()
Dim lis As MSForms.ListBox
Dim txt As MSForms.TextBox
Dim btn As MSForms.CommandButton
Dim com As MSForms.ComboBox
Dim numObjects As Integer: numObjects = Me.OLEObjects.Count
Dim obj() As Object
ReDim obj(1 To numObjects) As Object
Dim i As Integer: i = 0
Dim cttl As OLEObject
For Each ctrl In Me.OLEObjects
i = i + 1
Set obj(i) = ctrl.Object
Next ctrl
Dim result As String
For i = 1 To numObjects
If TypeOf obj(i) Is MSForms.ListBox Then
Set lis = obj(i): result = lis.Name
ElseIf TypeOf obj(i) Is MSForms.TextBox Then
Set txt = obj(i): result = txt.Name
ElseIf TypeOf obj(i) Is MSForms.CommandButton Then
Set btn = obj(i): result = btn.Name
ElseIf TypeOf obj(i) Is MSForms.ComboBox Then
Set ComboBox = obj(i): result = com.Name
Else
result = ""
End If
If (Not (result = "")) Then Debug.Print TypeName(obj(i)) & " name= " & result
Next i
For i = 1 To numObjects
Set lis = IsListBox(obj(i))
Set txt = IsTextBox(obj(i))
Set btn = IsCommandButton(obj(i))
Set com = IsComboBox(obj(i))
result = ""
If (Not (lis Is Nothing)) Then
result = "ListBox " & lis.Name
ElseIf (Not (txt Is Nothing)) Then
result = "TexttBox " & txt.Name
ElseIf (Not (btn Is Nothing)) Then
result = "CommandButton " & btn.Name
ElseIf (Not (com Is Nothing)) Then
result = "ComboBox " & com.Name
End If
Debug.Print result
Next i
End Sub
Function IsListBox(obj As Object) As MSForms.ListBox
Set IsListBox = IIf(TypeOf obj Is MSForms.ListBox, obj, Nothing)
End Function
Function IsTextBox(obj As Object) As MSForms.TextBox
Set IsTextBox = IIf(TypeOf obj Is MSForms.TextBox, obj, Nothing)
End Function
Function IsComboBox(obj As Object) As MSForms.ComboBox
Set IsComboBox = IIf(TypeOf obj Is MSForms.ComboBox, obj, Nothing)
End Function
Function IsCommandButton(obj As Object) As MSForms.CommandButton
Set IsCommandButton = IIf(TypeOf obj Is MSForms.CommandButton, obj, Nothing)
End Function
One use for it is a class for handling events in one class.
Private WithEvents intEvents As IntBoxEvents
Private WithEvents decEvents As DecBoxEvents
Private genEvents As Object
Private genControl as OLEobject
Public sub Delegate(ctrl As OLEObject)
set genControl = ctrl
' Code for creating intEvents or decEvents
if .... create intevents.... then set genEvents = new IntEvents ' pseudo code
if .... create decevents.... then set genEvents = new DecEvents ' pseudo code
end sub
I hope this helps others that struggle with casting controls
I am attempting to pull down the SECURITY_DES field value for a known CUSIP of unknown Fixed Income type (could be a corporate, treasury, mortgage- or asset-backed, etc.). I am using a declared variant to return the Bloomberg response, which has been showing "#N/A Sec" no matter how I structure my request.
I am running this within Excel and have the "Bloomberg Data Type Library" Reference added. I will paste the code below; I have tried formatting the CUSIP as /CUSIP/xxxxxxxxx, xxxxxxxxx CUSIP, IDxxxxxxxxx, all without luck. I tried Googling for formatting assistance but was having trouble finding matching discussions which worked out for me.
Dim BloombergModule As BlpData
Set BloombergModule = New BlpData
Dim BloombergReturnData As Variant
Dim BloombergFields(0) As String
' Prepare request for the SECURITY_DES field, "Security Description"...
BloombergFields(0) = "SECURITY_DES"
BloombergReturnData = BloombergModule.BLPSubscribe([CUSIP], BloombergFields)
I placed a breakpoint just after the last line pasted above; when I watch the BloombergReturnData variable, I see "#N/A Sec" in the BloombergReturnData(0,0) expression, which is what I expect -- only with the security's actual description returned instead of "#N/A Sec".
If you haven't caught on yet, I'm not a programmer by trade but have been using Bloomberg and VBA lately to fill some gaps around the office. Based on what I've read, I suspect that I have to pass in the fixed income type (Corp, Govt, Mtge, etc.) however I don't know that within my current data set and would have to track that down somehow.
Using Bloomberg's GUI, I can type in "IDxxxxxxxxx" (x's representing a CUSIP) to arrive at the main menu for a security.
Here are a few sample CUSIPs:
428236BR3,
500255AV6,
912828UE8,
49126PET3,
912828SC5,
912828MS6,
02225AFW7
How do I format my BLPSubscribe request to return the Security Description from Bloomberg successfully?
EDIT: This has been answered. I was using an old reference and structure which Bloomberg no longer supports. Using information from a blog post written by Mikael Katajamäki, I restructured my call using the updated reference ("Bloomberg API COM 3.5 Type Library") and the security name format "/cusip/xxxxxxxxx". The updated code is below (keep in mind that you will need the class module from Mikael Katajamäki's blog post if you intend on copy this structure):
' BCOM_wrapper is from Mikael Katajamäki's Bloomberg Class Module
Dim BloombergModule As BCOM_wrapper
Set BloombergModule = New BCOM_wrapper
Dim BloombergReturnData As Variant
Dim BloombergFields(0) As Variant
Dim BloombergSecurities(0) As Variant
Dim SecurityDescription As String
' Prepare request for the SECURITY_DES field, "Security Description"...
BloombergFields(0) = "SECURITY_DES"
BloombergSecurities(0) = ("/cusip/" & CStr(SQLResults![CUSIP]))
' getData() is from Mikael Katajamäki's Bloomberg Class Module
BloombergReturnData = BloombergModule.getData(REFERENCE_DATA, BloombergSecurities, BloombergFields)
' I used an absolute reference to the (0,0) slot since the nature of my use here is always just a single security
SecurityDescription = BloombergReturnData(0, 0)
Range("D" & CStr(Right(Target.Address, 2))).Value = SecurityDescription
Mikael Katajamäki's Blog Post: http://mikejuniperhill.blogspot.com/2013/06/bloomberg-v3com-api-wrapper-update-for.html
Archive of Mikael Katajamäki's class module (please notify me if this is against the rules and I will delete):
Option Explicit
'
' public enumerator for request type
Public Enum ENUM_REQUEST_TYPE
REFERENCE_DATA = 1
HISTORICAL_DATA = 2
BULK_REFERENCE_DATA = 3
End Enum
'
' constants
Private Const CONST_SERVICE_TYPE As String = "//blp/refdata"
Private Const CONST_REQUEST_TYPE_REFERENCE As String = "ReferenceDataRequest"
Private Const CONST_REQUEST_TYPE_BULK_REFERENCE As String = "ReferenceDataRequest"
Private Const CONST_REQUEST_TYPE_HISTORICAL As String = "HistoricalDataRequest"
'
' private data structures
Private bInputSecurityArray() As Variant
Private bInputFieldArray() As Variant
Private bOutputArray() As Variant
'
' BCOM objects
Private bSession As blpapicomLib2.Session
Private bService As blpapicomLib2.Service
Private bRequest As blpapicomLib2.REQUEST
Private bSecurityArray As blpapicomLib2.Element
Private bFieldArray As blpapicomLib2.Element
Private bEvent As blpapicomLib2.Event
Private bIterator As blpapicomLib2.MessageIterator
Private bIteratorData As blpapicomLib2.Message
Private bSecurities As blpapicomLib2.Element
Private bSecurity As blpapicomLib2.Element
Private bSecurityName As blpapicomLib2.Element
Private bSecurityField As blpapicomLib2.Element
Private bFieldValue As blpapicomLib2.Element
Private bSequenceNumber As blpapicomLib2.Element
Private bFields As blpapicomLib2.Element
Private bField As blpapicomLib2.Element
Private bDataPoint As blpapicomLib2.Element
'
' class non-object data members
Private bRequestType As ENUM_REQUEST_TYPE
Private bNumberOfDataPoints As Long
Private bCalendarType As String
Private bFrequency As String
Private bMaxDataPoints As Long
Private bStartDate As String
Private bEndDate As String
Private nSecurities As Long
Private nSecurity As Long
'
Public Function getData(ByVal requestType As ENUM_REQUEST_TYPE, _
ByRef securities() As Variant, ByRef fields() As Variant, _
Optional ByVal calendarType As String, Optional ByVal dataFrequency As String, _
Optional ByVal startDate As Date, Optional ByVal endDate As Date) As Variant()
'
bRequestType = requestType
bInputSecurityArray = securities
bInputFieldArray = fields
'
If (bRequestType = ENUM_REQUEST_TYPE.HISTORICAL_DATA) Then
'
bCalendarType = calendarType
bFrequency = dataFrequency
'
If ((startDate = CDate(0)) Or (endDate = CDate(0))) Then _
Err.Raise vbObjectError, "Bloomberg API", "Input parameters missing for historical data query"
bStartDate = convertDateToBloombergString(startDate)
bEndDate = convertDateToBloombergString(endDate)
End If
'
openSession
sendRequest
catchServerEvent
releaseObjects
getData = bOutputArray
End Function
'
Private Function openSession()
'
Set bSession = New blpapicomLib2.Session
bSession.Start
bSession.OpenService CONST_SERVICE_TYPE
Set bService = bSession.GetService(CONST_SERVICE_TYPE)
End Function
'
Private Function sendRequest()
'
Select Case bRequestType
Case ENUM_REQUEST_TYPE.HISTORICAL_DATA
ReDim bOutputArray(0 To UBound(bInputSecurityArray, 1), 0 To 0)
Set bRequest = bService.CreateRequest(CONST_REQUEST_TYPE_HISTORICAL)
bRequest.Set "periodicityAdjustment", bCalendarType
bRequest.Set "periodicitySelection", bFrequency
bRequest.Set "startDate", bStartDate
bRequest.Set "endDate", bEndDate
'
Case ENUM_REQUEST_TYPE.REFERENCE_DATA
Dim nSecurities As Long: nSecurities = UBound(bInputSecurityArray)
Dim nFields As Long: nFields = UBound(bInputFieldArray)
ReDim bOutputArray(0 To nSecurities, 0 To nFields)
'
Set bRequest = bService.CreateRequest(CONST_REQUEST_TYPE_REFERENCE)
'
Case ENUM_REQUEST_TYPE.BULK_REFERENCE_DATA
ReDim bOutputArray(0 To UBound(bInputSecurityArray, 1), 0 To 0)
Set bRequest = bService.CreateRequest(CONST_REQUEST_TYPE_BULK_REFERENCE)
'
End Select
'
Set bSecurityArray = bRequest.GetElement("securities")
Set bFieldArray = bRequest.GetElement("fields")
appendRequestItems
bSession.sendRequest bRequest
End Function
'
Private Function appendRequestItems()
'
Dim nSecurities As Long: nSecurities = UBound(bInputSecurityArray)
Dim nFields As Long: nFields = UBound(bInputFieldArray)
Dim i As Long
Dim nItems As Integer: nItems = getMax(nSecurities, nFields)
For i = 0 To nItems
If (i <= nSecurities) Then bSecurityArray.AppendValue CStr(bInputSecurityArray(i))
If (i <= nFields) Then bFieldArray.AppendValue CStr(bInputFieldArray(i))
Next i
End Function
'
Private Function catchServerEvent()
'
Dim bExit As Boolean
Do While (bExit = False)
Set bEvent = bSession.NextEvent
If (bEvent.EventType = PARTIAL_RESPONSE Or bEvent.EventType = RESPONSE) Then
'
Select Case bRequestType
Case ENUM_REQUEST_TYPE.REFERENCE_DATA: getServerData_reference
Case ENUM_REQUEST_TYPE.HISTORICAL_DATA: getServerData_historical
Case ENUM_REQUEST_TYPE.BULK_REFERENCE_DATA: getServerData_bulkReference
End Select
'
If (bEvent.EventType = RESPONSE) Then bExit = True
End If
Loop
End Function
'
Private Function getServerData_reference()
'
Set bIterator = bEvent.CreateMessageIterator
Do While (bIterator.Next)
Set bIteratorData = bIterator.Message
Set bSecurities = bIteratorData.GetElement("securityData")
Dim offsetNumber As Long, i As Long, j As Long
nSecurities = bSecurities.Count
'
For i = 0 To (nSecurities - 1)
Set bSecurity = bSecurities.GetValue(i)
Set bSecurityName = bSecurity.GetElement("security")
Set bSecurityField = bSecurity.GetElement("fieldData")
Set bSequenceNumber = bSecurity.GetElement("sequenceNumber")
offsetNumber = CInt(bSequenceNumber.Value)
'
For j = 0 To UBound(bInputFieldArray)
If (bSecurityField.HasElement(bInputFieldArray(j))) Then
Set bFieldValue = bSecurityField.GetElement(bInputFieldArray(j))
'
If (bFieldValue.DataType = BLPAPI_INT32) Then
bOutputArray(offsetNumber, j) = VBA.CLng(bFieldValue.Value)
Else
bOutputArray(offsetNumber, j) = bFieldValue.Value
End If
End If
Next j
Next i
Loop
End Function
'
Private Function getServerData_bulkReference()
'
Set bIterator = bEvent.CreateMessageIterator
nSecurity = nSecurity + 1
'
Do While (bIterator.Next)
Set bIteratorData = bIterator.Message
Set bSecurities = bIteratorData.GetElement("securityData")
Dim offsetNumber As Long, i As Long, j As Long
Dim nSecurities As Long: nSecurities = bSecurities.Count
'
Set bSecurity = bSecurities.GetValue(0)
Set bSecurityField = bSecurity.GetElement("fieldData")
'
If (bSecurityField.HasElement(bInputFieldArray(0))) Then
Set bFieldValue = bSecurityField.GetElement(bInputFieldArray(0))
'
If ((bFieldValue.NumValues - 1) > UBound(bOutputArray, 2)) Then _
ReDim Preserve bOutputArray(0 To UBound(bOutputArray, 1), 0 To bFieldValue.NumValues - 1)
'
For i = 0 To bFieldValue.NumValues - 1
Set bDataPoint = bFieldValue.GetValue(i)
bOutputArray(nSecurity - 1, i) = bDataPoint.GetElement(0).Value
Next i
End If
Loop
End Function
'
Private Function getServerData_historical()
'
Set bIterator = bEvent.CreateMessageIterator
Do While (bIterator.Next)
Set bIteratorData = bIterator.Message
Set bSecurities = bIteratorData.GetElement("securityData")
Dim nSecurities As Long: nSecurities = bSecurityArray.Count
Set bSecurityField = bSecurities.GetElement("fieldData")
Dim nItems As Long, offsetNumber As Long, nFields As Long, i As Long, j As Long
nItems = bSecurityField.NumValues
If (nItems = 0) Then Exit Function
If ((nItems > UBound(bOutputArray, 2))) Then _
ReDim Preserve bOutputArray(0 To nSecurities - 1, 0 To nItems - 1)
'
Set bSequenceNumber = bSecurities.GetElement("sequenceNumber")
offsetNumber = CInt(bSequenceNumber.Value)
'
If (bSecurityField.Count > 0) Then
For i = 0 To (nItems - 1)
'
If (bSecurityField.Count > i) Then
Set bFields = bSecurityField.GetValue(i)
If (bFields.HasElement(bFieldArray(0))) Then
'
Dim d(0 To 1) As Variant
d(0) = bFields.GetElement(0).GetValue(0)
d(1) = bFields.GetElement(1).GetValue(0)
bOutputArray(offsetNumber, i) = d
End If
End If
Next i
End If
Loop
End Function
'
Private Function releaseObjects()
'
Set bFieldValue = Nothing
Set bSequenceNumber = Nothing
Set bSecurityField = Nothing
Set bSecurityName = Nothing
Set bSecurity = Nothing
Set bSecurities = Nothing
Set bIteratorData = Nothing
Set bIterator = Nothing
Set bEvent = Nothing
Set bFieldArray = Nothing
Set bSecurityArray = Nothing
Set bRequest = Nothing
Set bService = Nothing
bSession.Stop
Set bSession = Nothing
End Function
'
Private Function convertDateToBloombergString(ByVal d As Date) As String
'
' convert date data type into string format YYYYMMDD
Dim dayString As String: dayString = VBA.CStr(VBA.Day(d)): If (VBA.Day(d) < 10) Then dayString = "0" + dayString
Dim MonthString As String: MonthString = VBA.CStr(VBA.Month(d)): If (VBA.Month(d) < 10) Then MonthString = "0" + MonthString
Dim yearString As String: yearString = VBA.Year(d)
convertDateToBloombergString = yearString + MonthString + dayString
End Function
'
Private Function getMax(ByVal a As Long, ByVal b As Long) As Long
'
getMax = a: If (b > a) Then getMax = b
End Function
You'd format it by placing "Cusip" after the CUSIP number.
So BloombergReturnData = BloombergModule.BLPSubscribe("xxxxxxx Cusip", BloombergFields) would return the required fields.
I tested using your Cusip list and it does populate the variant with the correct field data.
Please note that the ActiveX control you're using is no longer supported by Bloomberg. There is a COM Data Control using the "v3" interface.
I have TextBoxes on UserForm and in Excel File (unfortunately).
I can do the loop on those in UserForm, and it works perfectly:
Dim txt(1 To 20) As String
txt(3)=("txtCompany")
txt(4)=("txtDataSource")
....
For i = 1 To 20
If frmInfo.Controls(txt(i)).Value <>
Worksheets(SheetNameDataBaze).Cells(ERow, i).Value Then ....
However, there is a huge problem with controls placed on the worksheet.
I tried:
Worksheets(SheetNameDataBaze).Controls(txt(i)).Value
Worksheets(SheetNameDataBaze).TextBox(txt(i)).Value
Worksheets(SheetNameDataBaze).OLEObjects(txt(i)).Value
Worksheets(SheetNameDataBaze).Shapes(txt(i)).Value
Worksheets(SheetNameDataBaze).txt(i).Value
nothing worked.
How should I define it?
It would be much easier then preparing the if statement for each TextBox.
I'm assuming that your textboxes on the worksheet are ActiveX controls and not forms controls. If so, then does this work for you?
Sub ReferToTextboxes()
Dim txt As MSForms.TextBox
Dim o As OLEObject
For Each o In Sheet1.OLEObjects
If o.progID = "Forms.TextBox.1" Then
Set txt = o.Object
'now you can refer to txt and do what you need
Debug.Print txt.Text
End If
Next o
End Sub
I finally used:
Private Sub FunctionalProgramNew()
Dim bLoop As Double
Dim eLoop As Double
bLoop = 8
eLoop = 13
Dim txt(8 To 13) As String
txt(8) = ("txtFuel_1")
txt(9) = ("txtFuel_2")
txt(10) = ("txtFuel_3")
txt(11) = ("txtProduct_1")
txt(12) = ("txtProduct_2")
txt(13) = ("txtProduct_3")
Dim txtBox(8 To 13) As MSForms.TextBox
For i = bLoop To eLoop
Set txtBox(i) = Worksheets(SheetNameModel).OLEObjects(txt(i)).Object
Next i
For i = bLoop To eLoop
If txtBox(i).Value <> CStr(Cells(ActiveCell.row, ActiveCell.Column + i - 2).Value) Then
MsgBox ("Error code: " & txt(i))
End If
Next i
End Sub
I had previously asked about how to evenly distribute the items in n lists into a single list and was referred to this question: Good algorithm for combining items from N lists into one with balanced distribution?.
I made a practical example of my solution for this in VBA for Excel, since my application for this was resorting my Spotify lists which can be easily pasted into Excel for manipulation. Assumptions are that you have a headerless worksheet (wsSource) of songs with columns A, B, C representing Artist, Song, SpotifyURI respectively, a "Totals" worksheet (wsTotals) containing the sum of songs for each Artist from wsSource sorted in descending order, and a "Destination" worksheet where the new list will be created. Could I get some suggestions to improve this? I was going to get rid of the totals worksheet and have this portion done in code, but I have to go and I wanted to go ahead and put this out there. Thanks!
Sub WeaveSort()
Dim wb As Workbook
Dim wsDest As Worksheet
Dim wsSource As Worksheet
Dim wsTotals As Worksheet
Dim i As Integer
Dim iLast As Integer
Dim iDest As Integer
Dim iSource As Integer
Dim iOldRow As Integer
Dim iNewRow As Integer
Dim dDiff As Double
Dim dDiffSum As Double
Set wb = ThisWorkbook
Set wsTotals = wb.Worksheets("Totals")
Set wsSource = wb.Worksheets("Source")
Set wsDest = wb.Worksheets("Dest")
iLast = wsTotals.Range("A1").End(xlDown).Row - 1
For i = 2 To iLast
iSource = wsTotals.Range("B" & i).Value
iDest = wsDest.Range("A99999").End(xlUp).Row
If i = 2 Then
wsDest.Range("A1:C" & iSource).Value2 = wsSource.Range("A1:C" & iSource).Value2
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
GoTo NextI
End If
dDiff = iDest / iSource
dDiffSum = 0
iNewRow = 0
For iOldRow = 1 To iSource
dDiff = iDest / iSource
dDiffSum = dDiffSum + dDiff
iNewRow = Round(dDiffSum, 0)
wsSource.Rows(iOldRow).Copy
wsDest.Rows(iNewRow).Insert xlShiftDown
iDest = iDest + 1
Next iOldRow
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
NextI:
Next i
End Sub
Great question! I would take an object oritentated approach. Also I didn;t think it was clear what the logic was so here is my answer. Two classes and one normal module. Save these separately with the filenames ListManager.cls, List.cls, tstListManager.bas
So the ListManager.cls is this
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ListManager"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private mdic As Object
Public Sub Initialise(ByVal vLists As Variant)
Set mdic = VBA.CreateObject("Scripting.Dictionary")
Dim vListLoop As Variant
For Each vListLoop In vLists
Dim oList As List
Set oList = New List
oList.Initialise vListLoop, ""
mdic.Add mdic.Count, oList
Next
End Sub
Public Function WeaveSort() As Variant
Dim dicReturn As Object
Set dicReturn = VBA.CreateObject("Scripting.Dictionary")
Dim oNextList As List
Set oNextList = Me.WhichListHasLeastProgress
While oNextList.PercentageDone <= 1
Dim vListItem As Variant
vListItem = oNextList.GetListItem
dicReturn.Add dicReturn.Count, vListItem
oNextList.MoveNext
Set oNextList = Me.WhichListHasLeastProgress
Wend
Dim vItems As Variant
vItems = dicReturn.Items
'I don't like this bit
ReDim vRet(1 To dicReturn.Count, 1 To 1)
Dim lLoop As Long
For lLoop = 0 To dicReturn.Count - 1
vRet(lLoop + 1, 1) = vItems(lLoop)
Next lLoop
WeaveSort = vRet
End Function
Public Function WhichListHasLeastProgress() As List
Dim vKeyLoop As Variant
Dim oListLoop As List
Dim oLeastProgress As List
For Each vKeyLoop In mdic.keys
Set oListLoop = mdic.Item(vKeyLoop)
If oLeastProgress Is Nothing Then
'nothing to compare yet
Set oLeastProgress = oListLoop
Else
If oListLoop.PercentageDone < oLeastProgress.PercentageDone Then
'definitely take this new candidate
Set oLeastProgress = oListLoop
ElseIf oListLoop.PercentageDone = oLeastProgress.PercentageDone And oListLoop.Size > oListLoop.Size Then
'close thing, both showing equal progress but we should give it to the one with the bigger "queue"
Set oLeastProgress = oListLoop
Else
'no swap
End If
End If
Next
'return the answer
Set WhichListHasLeastProgress = oLeastProgress
End Function
and the List.cls file is
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "List"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private mvList As Variant
Private mlCount As Long
Private mlCursor As Long
Private mvName As Variant
Public Function Initialise(ByRef vList As Variant, ByVal vName As Variant)
Debug.Assert TypeName(vList(1, 1)) <> "" ' this will break unless you specify a 2d array
Debug.Assert LBound(vList, 1) = 1 ' this ensure you got it from a sheet
mvList = vList
mlCount = UBound(mvList)
mlCursor = 1
mvName = vName
End Function
Public Function GetListItem()
GetListItem = mvList(mlCursor, 1)
End Function
Public Function Name() As Variant
Name = mvName
End Function
Public Function MoveNext() As Boolean
mlCursor = mlCursor + 1
MoveNext = (mlCursor < mlCount)
End Function
Public Function Size() As Long
Size = mlCount
End Function
Public Function PercentageDone() As Double
PercentageDone = mlCursor / mlCount
End Function
The last file is this tstListManager.bas
Attribute VB_Name = "tstListManager"
Option Explicit
Sub test()
Dim oListMan As ListManager
Set oListMan = New ListManager
Dim vLists As Variant
vLists = VBA.Array(ThisWorkbook.Sheets("Source").Range("A1:A3").Value2, _
ThisWorkbook.Sheets("Source").Range("B1:B2").Value2, _
ThisWorkbook.Sheets("Source").Range("C1:C5").Value2)
oListMan.Initialise vLists
Dim vSorted As Variant
vSorted = oListMan.WeaveSort
Dim lTotal As Long
ThisWorkbook.Sheets("Dest").Range("A1").Resize(UBound(vSorted, 1)).Value2 = vSorted
End Sub
Finally, the test data was in A1:A3 B1:B2 C1:C5
You should note I have abstracted away any Excel reading/writing logic and the pure weavesort logic is not cluttered.
Feel free to reject outright. Object orientation can be quite controversial and we think differently. :)