Topic: VBA and Arrays

[David Hall]

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.

Code: [Select]

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

Code: [Select]

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



[Keith™]

I would redim your FoundItems to zero when you run the routine ... i.e. Instead of Erase ... just me ... but you can use Erase ... I just have found it to be unreliable ... Also ... you are trying to redim BOTH dimensions of the array, you can only redim the LAST dimension .. thus instead of
ReDim Preserve FoundItems(m + 1, m + 1) 'this is actually incorrect anyway as you only have 2 dimensions for the second value (0 & 1) bu it must be turned around and ReDim the second dimension only ...

ReDim Preserve FoundItems(1, m + 1) thus you have unlimited dims with 2 values That being FoundItems(0, x) and FoundItems(1, x) ...

I have edited the code below as I see it, but I have not tested it since I don't have anything here handy to test it on.

Code: [Select]

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()
    Redim FoundItems(1,0) As String
    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, 2)
        s = GetPartInformation(FoundItems(0 , j), FoundItems(1, j))
        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, 2)
    If Err.Number = 9 Then
        m = 0
    Else
        For i = 1 To m
            If FoundItems(0, i) = StoresNumber Then
                found = True
                FoundItems(1, i) = CInt(FoundItems(1, i)) + 1
            End If
        Next
    End If
    If found = False Then

        ReDim Preserve FoundItems(1, m + 1)
        FoundItems(0, m + 1) = StoresNumber
        FoundItems(1, m + 1) = 1
    End If
End Sub


I hope it works 

[David Hall]

you can only redim the LAST dimension ..

I learned this just before going home yesterday.  Back to the drawing board.  I have an idea though...

[Keith™]

Let me tell you what I have done in the past ... an array of arrays ...

This is the concept ...

Code: [Select]

Dim Array1() As Variant
Dim Array2() As Variant

For m = 0 to whatever
 Array2(m + 1) = value
Next m

Array1(j) = Array2


[David Hall]

Funny how things that you thought you would never have to look at again seem to come back to life.....

Almost 2 years later, my boss wants to look at exporting qualifying block quanities to either txt(useable) or XML(preferred).

Any ideas on how I should do this?  Keith and I beat this up a little back in 07, and I haven't thought about it since

[Matt__W]

Funny how things that you thought you would never have to look at again seem to come back to life.....

Almost 2 years later, my boss wants to look at exporting qualifying block quanities to either txt(useable) or XML(preferred).

Any ideas on how I should do this?  Keith and I beat this up a little back in 07, and I haven't thought about it since

I dabbled with XML a few years back.  As I recall, it was rather simple and straightforward.  You do have to have a reference added for XML - can't remember what it is exactly - Microsoft XML (some version #?)

[David Hall]

writing out to XML should be pretty easy, I agree.  Its working with the array that Im worried about.  I have never really used them.  The concept looks pretty straight forward though.  I'll keep you posted

[David Hall]

well here is what I have so far.

Code: [Select]

Option Explicit
Dim strStoresNumber() As String
Dim intBlockCount As Integer

Public Sub BOM()
Dim objSelSet As AcadSelectionSet
Dim intType(0 To 1) As Integer
Dim varData(0 To 1) As Variant
Dim objBlockRef As AcadBlockReference
Dim strBlockName As String
Dim varArray1 As Variant
Dim intCount As Integer
Dim found As Boolean

ReDim strStoresNumber(0)
intBlockCount = 0
intType(0) = 0: varData(0) = "INSERT"
intType(1) = 2: varData(1) = "*"

ACADSelSet objSelSet, "BOM"
objSelSet.Select Mode:=acSelectionSetAll, filtertype:=intType, Filterdata:=varData

For Each objBlockRef In objSelSet
found = False
      If objBlockRef.HasAttributes Then
          varArray1 = objBlockRef.GetAttributes
                For intCount = LBound(varArray1) To UBound(varArray1)
                  Select Case varArray1(intCount).TagString
                        Case "STORESNUMBER"
                              Dim varStoresNumber As Variant
'                              varStoresNumber = varArray1(intCount).TextString
                              varStoresNumber = objBlockRef.Name
                             
                              Dim m As Integer, i As Integer
                              m = UBound(strStoresNumber)
                              If m = 0 Then
                                    strStoresNumber(0) = varStoresNumber
                                    ReDim Preserve strStoresNumber(UBound(strStoresNumber) + 1)
                                    found = True
                              Else
                                    For i = 0 To m
                                          If strStoresNumber(i) = varStoresNumber Then
                                          found = True
                                          Exit For
                                          End If
                                    Next
                              End If
                  End Select
            Next intCount
      End If
      If found = False Then
      strStoresNumber(UBound(strStoresNumber)) = varStoresNumber
      ReDim Preserve strStoresNumber(UBound(strStoresNumber) + 1)
      End If
Next
ReDim Preserve strStoresNumber(UBound(strStoresNumber) - 1)

For i = 0 To UBound(strStoresNumber)

intBlockCount = 0
intType(0) = 0: varData(0) = "INSERT"
intType(1) = 2: varData(1) = strStoresNumber(i)

ACADSelSet objSelSet, "BOM"
objSelSet.Select Mode:=acSelectionSetAll, filtertype:=intType, Filterdata:=varData
intBlockCount = objSelSet.Count
MsgBox "You have " & intBlockCount & " of " & strStoresNumber(i) & " blocks"

'write out the XML here

Next
End Sub



Public Function ACADSelSet(funcObjSelSet As AcadSelectionSet, funcSelectionSetName As String)
Dim objSelCol As AcadSelectionSets
  On Error GoTo Err_Control
  Set objSelCol = ThisDrawing.SelectionSets
  For Each funcObjSelSet In objSelCol
    If funcObjSelSet.Name = funcSelectionSetName Then
      funcObjSelSet.Clear
      funcObjSelSet.Delete
      Exit For
    End If
  Next
Set funcObjSelSet = objSelCol.Add(funcSelectionSetName)
Exit_Here:
Exit Function
Err_Control:
Select Case Err.Number
Case -2145386300
MsgBox "ACAD_Functions.ACADSelSet" & vbCrLf & Err.Number & " - " & Err.Description
Case Else
MsgBox "ACAD_Functions.ACADSelSet" & vbCrLf & Err.Number & " - " & Err.Description
End Select
End Function
It builds an array based on a block having an attribute, then pops up a msgbox telling me how many, which I need to swap out for the XML part.  Stay tuned in for more updates.......

[David Hall]

OK, I'm stuck.  I cant figure out how to send out to XML.  I know I have to send it to the child nodes, but I cant seem to get them to be recognized.  Anybody ever tried this?

[fixo]

Here is an example that will get you started

Code: [Select]

Option Explicit
Public Const strFilePath As String = "C:\TestXML.xml"

Sub ExtractToXML()

    Dim objDoc As MSXML2.DOMDocument
    Dim objNode As MSXML2.IXMLDOMNode
    Dim objRoot As MSXML2.IXMLDOMElement
    Dim objElem As MSXML2.IXMLDOMElement
    Dim oblkRef As AcadBlockReference
    Dim ent As AcadEntity
    Dim ar As Variant
    Dim i As Integer
    Set objDoc = New DOMDocument
    objDoc.resolveExternals = True

    Set objNode = objDoc.createProcessingInstruction( _
                  "xml", "version='1.0' encoding='UTF-8'")
    Set objNode = objDoc.insertBefore(objNode, _
                                      objDoc.childNodes.Item(0))

    Set objRoot = objDoc.createElement("blockdata")
    Set objDoc.documentElement = objRoot
    objRoot.setAttribute "xmlns:od", _
                         "urn:schemas-microsoft-com:officedata"

    For Each ent In ThisDrawing.ModelSpace
        If TypeOf ent Is AcadBlockReference Then
            Set oblkRef = ent
            If oblkRef.HasAttributes Then
                Set objElem = objDoc.createElement(oblkRef.Name)
                objRoot.appendChild objElem
                ar = oblkRef.GetAttributes
                For i = LBound(ar) To UBound(ar)
                    Set objNode = objDoc.createElement(ar(i).TagString)
                    objNode.Text = ar(i).TextString
                    objElem.appendChild objNode
                Next i

            End If
        End If
    Next ent
    objDoc.Save strFilePath
End Sub
~'J'~

[David Hall]

thanks,  I will see what I can break with that

[David Hall]

It worked perfectly with a few tweaks.

[fixo]

Glad you solved it
Cheers

~'J'~