TheSwamp
Code Red => VB(A) => Topic started by: David Hall on February 01, 2007, 04:25:33 PM
-
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
-
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.
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 ;-)
-
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...
-
Let me tell you what I have done in the past ... an array of arrays ...
This is the concept ...
Dim Array1() As Variant
Dim Array2() As Variant
For m = 0 to whatever
Array2(m + 1) = value
Next m
Array1(j) = Array2
-
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
-
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 #?)
-
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
-
well here is what I have so far.
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.......
-
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?
-
Here is an example that will get you started
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'~
-
thanks, I will see what I can break with that
-
It worked perfectly with a few tweaks.
-
Glad you solved it
Cheers :)
~'J'~