社区 › VB › VBA和数组

Keith™ 发表于 2007-2-1 16:25:33

VBA和数组

好吧，现在我完全迷失了我正在做的这个数组搜索的东西。 我理解其中的逻辑，但没有任何效果。 实际上，它第一次工作，但之后不起作用。代码 1 是我试图使工作的版本。 代码2是一个简化的版本，我试图让它工作，所以我可以修复代码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

代码2
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

**** Hidden Message *****

Keith™ 发表于 2007-2-1 18:00:23

当您运行例程时，我会将您的FoundItems重置为零......即代替擦除......只有我......但是您可以使用擦除......我只是发现它不可靠......此外...你试图重拨数组的两个维度，你只能重拨最后一个维度...因此而不是
ReDim保留FoundItems（m+1， m+1）'这实际上是不正确的，因为你只有2个维度的第二个值（0&1），但是它必须被转过来，并且ReDim只有第二个维度...
ReDim保留FoundItems（1， m+1）因此您有无限的dims与2个值即FoundItems（0， x）和FoundItems（1， x）...
我已经编辑了下面的代码，因为我看到了它，但我还没有测试它，因为我这里没有任何方便测试它的东西.
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

我希望能行

Matt__W 发表于 2007-2-2 10:07:48

我昨天回家前就知道了。回到绘图板。不过我有个主意。。。

fixo 发表于 2007-2-2 10:14:56

几年前我尝试过XML。据我回忆，这相当简单明了。您必须为XML添加一个引用—记不清具体是什么了— Microsoft XML(某个版本号？)

fixo 发表于 2008-10-27 17:52:39

我同意，写出XML应该很容易。这是我担心的阵列。我从来没有真正使用过它们。不过，这个概念看起来相当直截了当。我会随时通知你的

Keith™ 发表于 2008-10-28 08:25:22

好吧，我卡住了。我不知道如何发送到XML。我知道我必须把它发送到子节点，但是我似乎不能让它们被识别。有人试过这个吗？

Keith™ 发表于 2008-10-28 10:45:36

这是一个让你开始学习的例子
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'~

fixo 发表于 2008-10-28 15:49:06

只要稍加调整，它就能完美工作。

Keith™ 发表于 2008-10-28 18:05:58

很高兴你解决了这个问题
干杯
~'J'~

查看完整版本: VBA和数组