OK, now I'm completely lost with this array searching thing I'm working on. I understand the logic, but nothing is working. Actually, it works the first time through, but doesn't work after that. Code 1 is the version I'm trying to make work. Code 2 is a much simplified version I'm trying to get working so I can fix code 1.
Option Explicit
Dim FoundItems() As String, intType(0 To 1) As Integer, varData(0 To 1) As Variant
Dim objSelCol As AcadSelectionSets, objSelSet As AcadSelectionSet, objBlkRef As AcadBlockReference
Dim varArray1 As Variant, intCount As Integer
Public Sub PMS_v2()
Erase FoundItems
Set objSelCol = ThisDrawing.SelectionSets
For Each objSelSet In objSelCol
If objSelSet.Name = "PMS" Then
objSelSet.Delete
Exit For
End If
Next
Set objSelSet = objSelCol.Add("PMS")
intType(0) = 0: varData(0) = "INSERT"
intType(1) = 2: varData(1) = "*"
objSelSet.Select Mode:=acSelectionSetAll, filtertype:=intType, filterdata:=varData
For Each objBlkRef In objSelSet
If objBlkRef.HasAttributes Then
varArray1 = objBlkRef.GetAttributes
For intCount = LBound(varArray1) To UBound(varArray1)
Select Case varArray1(intCount).TagString
Case "STORESNUMBER"
strStoresNumber = varArray1(intCount).TextString
IncrimentCount strStoresNumber
End Select
Next intCount
End If
Next
'Now Extract the Information
'Extract to Tab Delimited File
Dim fso, fl, fln, s
Dim j As Integer
fln = "M:\PARTS-LIST\PMS.txt"
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(fln) Then
fso.DeleteFile fln
End If
Set fl = fso.CreateTextFile(fln)
For j = 1 To UBound(FoundItems)
s = GetPartInformation(FoundItems(j, 0), FoundItems(j, 1))
fl.WriteLine s
Next
fl.Close
End Sub
Private Function GetPartInformation(StoresNumber As String, Quantity As String) As String
Dim objXML As New DOMDocument
Dim objRoot As IXMLDOMElement
Dim objLNode As IXMLDOMElement
Dim s As String
objXML.Load "M:\PARTS-LIST\partslist.xml"
Set objRoot = objXML.documentElement
For Each objLNode In objRoot.childNodes
If StoresNumber = objLNode.childNodes(0).Text Then
s = Quantity & vbTab & StoresNumber & vbTab & objLNode.childNodes(1).Text & vbTab & objLNode.childNodes(2).Text & vbTab & objLNode.childNodes(3).Text
End If
Next objLNode
Set objXML = Nothing
GetPartInformation = s
End Function
Private Sub IncrimentCount(StoresNumber As String)
On Error Resume Next
Dim i As Integer, m As Integer
Dim found As Boolean
found = False
m = UBound(FoundItems, 1)
If Err.Number = 9 Then
m = 0
Else
For i = 1 To m
If FoundItems(i, 0) = StoresNumber Then
found = True
FoundItems(i, 1) = CInt(FoundItems(i, 1)) + 1
End If
Next
End If
If found = False Then
ReDim Preserve FoundItems(m + 1, m + 1)
FoundItems(m + 1, 0) = StoresNumber
FoundItems(m + 1, 1) = 1
End If
End Sub
code2
Option Explicit
Dim intType(0 To 1) As Integer, varData(0 To 1) As Variant, FoundItems() As String
Dim objSelCol As AcadSelectionSets, objSelSet As AcadSelectionSet, objBlkRef As AcadBlockReference
Dim varArray1 As Variant, intCount As Integer
Public Sub PMS_v3()
Erase FoundItems
IncrimentCount_v2 "1234"
IncrimentCount_v2 "1234"
IncrimentCount_v2 "5678"
IncrimentCount_v2 "5678"
IncrimentCount_v2 "1234"
IncrimentCount_v2 "1234"
IncrimentCount_v2 "5678"
IncrimentCount_v2 "1234"
IncrimentCount_v2 "1234"
End Sub
Private Sub IncrimentCount_v2(StoresNumber As String)
Dim i As Integer, m As Integer, cnt As Integer
Dim found As Boolean
On Error GoTo Err_Control
found = False
i = UBound(FoundItems, 1)
m = UBound(FoundItems, 2)
For i = 1 To m
If FoundItems(i, 1) = StoresNumber Then
found = True
FoundItems(i, 2) = CInt(FoundItems(i, 2)) + 1
End If
Next i
Exit Sub
Err_Control:
If Err.Number = 9 Then m = 1
Resume Next
End Sub