指向存储为集合/字典项VBA的数组的指针

时间：2017-04-21 21:19:04

标签： excel vba excel-vba vb6 safearray

对于变量数组，每个元素都是一个双数组，我可以执行以下操作：

Sub test()
    Dim col as Collection
    Dim A() as Double
    Dim B() as Double

    Set col = New Collection
    col.Add A, "A"
    CopyMemoryArray B, ByVal VarPtr(col("A")) + 8, PTR_LENGTH '4 or 8
    'Do something
    ZeroMemoryArray B, PTR_LENGTH
End Sub
然后，

A和B将指向内存中的同一个块。 （设置W = vntArr（1）会创建一个副本。对于非常大的数组，我想避免这种情况。）

我试图做同样的事情，但是有了收藏品：

#If Win64 Then
    Public Const PTR_LENGTH As Long = 8
#Else
    Public Const PTR_LENGTH As Long = 4
#End If

Public Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Const VT_BYREF As Long = &H4000&
Private Const S_OK As Long = &H0&

Private Function pArrPtr(ByRef arr As Variant) As LongPtr
    Dim vt As Integer

    CopyMemory vt, arr, 2
    If (vt And vbArray) <> vbArray Then
        Err.Raise 5, , "Variant must contain an array"
    End If
    If (vt And VT_BYREF) = VT_BYREF Then
        CopyMemory pArrPtr, ByVal VarPtr(arr) + 8, PTR_LENGTH
        CopyMemory pArrPtr, ByVal pArrPtr, PTR_LENGTH
    Else
        CopyMemory pArrPtr, ByVal VarPtr(arr) + 8, PTR_LENGTH
    End If
End Function

Private Function GetPointerToData(ByRef arr As Variant) As LongPtr
    Dim pvDataOffset As Long
    #If Win64 Then
        pvDataOffset = 16 '4 extra unused bytes on 64bit machines
    #Else
        pvDataOffset = 12
    #End If
    CopyMemory GetPointerToData, ByVal pArrPtr(arr) + pvDataOffset, PTR_LENGTH
End Function

Sub CollectionWorks()
    Dim A(1 To 100, 1 To 50) As Double

    A(3, 1) = 42

    Dim c As Collection
    Set c = New Collection

    c.Add A, "A"

    Dim ActualPointer As LongPtr
    ActualPointer = GetPointerToData(c("A"))

    Dim r As Double
    CopyMemory r, ByVal ActualPointer + (0 + 2) * 8, 8

    MsgBox r  'Displays 42
End Sub

这种工作，但由于某种原因，col（＆＃34; A＆＃34;）返回的安全数组结构（包含在Variant数据类型中，类似于上面的变量数组）只包含一些外部属性，如数字维度和暗边界，但指向pvData本身的指针是空的，因此CopyMemoryArray调用导致崩溃。 （设置B = col（＆＃34; A＆＃34;）工作正常。）与Scripting.Dictionary的情况相同。

有谁知道这里发生了什么？ enter image description here

修改

> glm.1=glm(Gender~Math.Scaled.Scores.2011+Math.Scaled.Scores.2012+Math.Scaled.Scores.2013+School, data= Ed, family=binomial)
> summary(glm.1)

Call:
glm(formula = Gender ~ Math.Scaled.Scores.2011 + Math.Scaled.Scores.2012 + 
    Math.Scaled.Scores.2013 + School, family = binomial, data = Ed)

Deviance Residuals: 
   Min      1Q  Median      3Q     Max  
-1.389  -1.212   1.058   1.138   1.376  

Coefficients:
                          Estimate Std. Error z value Pr(>|z|)  
(Intercept)              3.331e-02  2.223e-01   0.150   0.8809  
Math.Scaled.Scores.2011 -7.837e-04  5.401e-04  -1.451   0.1468  
Math.Scaled.Scores.2012  5.279e-05  6.298e-04   0.084   0.9332  
Math.Scaled.Scores.2013  9.878e-04  6.258e-04   1.579   0.1144  
SchoolB                  5.198e-03  2.091e-01   0.025   0.9802  
SchoolC                 -3.341e-02  2.120e-01  -0.158   0.8748  
SchoolD                 -6.354e-02  2.348e-01  -0.271   0.7867  
SchoolE                  9.032e-03  2.159e-01   0.042   0.9666  
SchoolF                 -3.553e-01  2.322e-01  -1.530   0.1260  
SchoolG                 -1.845e-01  2.325e-01  -0.794   0.4274  
SchoolH                 -2.358e-01  2.308e-01  -1.022   0.3069  
SchoolI                  1.351e-02  2.162e-01   0.062   0.9502  
SchoolJ                  1.220e-01  2.395e-01   0.509   0.6105  
SchoolK                 -3.845e-02  2.388e-01  -0.161   0.8721  
SchoolL                 -1.637e-02  2.018e-01  -0.081   0.9354  
SchoolML                 1.051e-01  2.304e-01   0.456   0.6483  
SchoolN                  4.214e-02  2.310e-01   0.182   0.8552  
SchoolO                 -1.764e-02  2.248e-01  -0.078   0.9374  
SchoolP                  3.455e-02  2.258e-01   0.153   0.8784  
SchoolQ                 -2.496e-01  2.066e-01  -1.208   0.2270  
SchoolR                 -4.046e-01  2.187e-01  -1.851   0.0642 .
SchoolS                  1.483e-02  2.139e-01   0.069   0.9447  
SchoolT                 -2.566e-01  2.334e-01  -1.100   0.2714  
SchoolU                 -4.166e-02  2.088e-01  -0.199   0.8419  
SchoolV                 -4.073e-01  2.246e-01  -1.813   0.0698 .
SchoolW                  1.074e-03  2.203e-01   0.005   0.9961  
SchoolX                 -1.056e-01  2.190e-01  -0.482   0.6298  
---
Signif. codes:  0 ‘***’ 0.001 ‘**’ 0.01 ‘*’ 0.05 ‘.’ 0.1 ‘ ’ 1

(Dispersion parameter for binomial family taken to be 1)

    Null deviance: 5997.2  on 4327  degrees of freedom
Residual deviance: 5971.4  on 4301  degrees of freedom
AIC: 6025.4

Number of Fisher Scoring iterations: 3

2 个答案:

答案 0 :(得分：6)

VB旨在隐藏复杂性。通常，这会产生非常简单直观的代码，有时却不会。

VARIANT可以包含非VARIANT数据的数组，没有问题，例如正确的Double数组。但是当你尝试从VB访问这个数组时，你不会得到一个原始的Double，就像它实际存储的是blob一样，你将它包装在一个临时的Variant中，在访问时间，特别是对于声明As Variant的数组突然产生值As Double这一事实并不让您惊讶。您可以在此示例中看到：

Sub NoRawDoubles()
  Dim A(1 To 100, 1 To 50) As Double
  Dim A_wrapper As Variant

  A_wrapper = A

  Debug.Print VarPtr(A(1, 1)), VarPtr(A_wrapper(1, 1))
  Debug.Print VarPtr(A(3, 3)), VarPtr(A_wrapper(3, 3))
  Debug.Print VarPtr(A(5, 5)), VarPtr(A_wrapper(5, 5))
End Sub

在我的电脑上，结果是：

88202488      1635820 
88204104      1635820 
88205720      1635820

来自A的元素实际上是不同的，并且位于存储器中，它们应该位于数组中，并且每个元素的大小为8个字节，而＆＃34;元素＆＃34; A_wrapper实际上是相同的＆＃34;元素＆＃34; - 重复三次的数字是临时Variant的地址，大小为16字节，用于保存数组元素以及编译器决定重用的地址。

这就是为什么以这种方式返回的数组元素不能用于指针运算。

集合本身不会为此问题添加任何内容。事实上，Collection必须将它存储的数据包装在一个混乱的Variant中。将数组存储在任何其他地方的Variant中时会发生这种情况。

要获得适合指针运算的实际解包数据指针，您需要查询来自SAFEARRAY*的{​​{1}}指针，它可以存储一个或两个间接级别，并取来自那里的数据指针。

在previous examples的基础上，天真的非x64兼容代码将是：

Variant

然后可以使用以下非x64兼容方式：

Private Declare Function GetMem2 Lib "msvbvm60" (ByVal pSrc As Long, ByVal pDst As Long) As Long  ' Replace with CopyMemory if feel bad about it
Private Declare Function GetMem4 Lib "msvbvm60" (ByVal pSrc As Long, ByVal pDst As Long) As Long  ' Replace with CopyMemory if feel bad about it

Private Const VT_BYREF As Long = &H4000&

Private Function pArrPtr(ByRef arr As Variant) As Long  'Warning: returns *SAFEARRAY, not **SAFEARRAY
  'VarType lies to you, hiding important differences. Manual VarType here.
  Dim vt As Integer
  GetMem2 ByVal VarPtr(arr), ByVal VarPtr(vt)

  If (vt And vbArray) <> vbArray Then
    Err.Raise 5, , "Variant must contain an array"
  End If


  'see https://msdn.microsoft.com/en-us/library/windows/desktop/ms221627%28v=vs.85%29.aspx
  If (vt And VT_BYREF) = VT_BYREF Then
    'By-ref variant array. Contains **pparray at offset 8
    GetMem4 ByVal VarPtr(arr) + 8, ByVal VarPtr(pArrPtr)  'pArrPtr = arr->pparray;
    GetMem4 ByVal pArrPtr, ByVal VarPtr(pArrPtr)          'pArrPtr = *pArrPtr;
  Else
    'Non-by-ref variant array. Contains *parray at offset 8
    GetMem4 ByVal VarPtr(arr) + 8, ByVal VarPtr(pArrPtr)  'pArrPtr = arr->parray;
  End If

End Function

Private Function GetPointerToData(ByRef arr As Variant) As Long
  GetMem4 pArrPtr(arr) + 12, VarPtr(GetPointerToData)
End Function

请注意，我不确定Sub CollectionWorks() Dim A(1 To 100, 1 To 50) As Double A(3, 1) = 42 Dim c As Collection Set c = New Collection c.Add A, "A" Dim ActualPointer As Long ActualPointer = GetPointerToData(c("A")) Dim r As Double GetMem4 ActualPointer + (0 + 2) * 8, VarPtr(r) GetMem4 ActualPointer + (0 + 2) * 8 + 4, VarPtr(r) + 4 MsgBox r 'Displays 42 End Sub 每次都返回相同的实际数据，而不是随意制作副本，因此可能不会建议以这种方式缓存指针，并且您可能最好先关闭将c("A")的结果保存到变量中，然后调用c("A")。

显然应该重写这个以使用GetPointerToData和LongPtr，明天我可能会这样做，但你明白了。

答案 1 :(得分：1)

如果将两个基本变量都视为Variant，则会更容易。

Option Explicit

#If Vba7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare PtrSafe Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
#Else
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Sub FillMemory Lib "kernel32" Alias "RtlFillMemory" (Destination As Any, ByVal Length As Long, ByVal Fill As Byte)
#End If


Sub test()
    Dim col As Variant
    Dim B As Variant
    Dim A() As Double

    ReDim A(1 To 100, 1 To 200)
    A(1, 1) = 42
    Set col = New Collection
    col.Add A, "A"
    Debug.Print col("A")(1, 1)

    CopyMemory B, col, 16
    Debug.Print B("A")(1, 1)

    FillMemory B, 16, 0
End Sub

另请参阅这些有用的链接

Partial Arrays by reference

Copy an array reference in VBA

How do I slice an array in Excel VBA?

http://bytecomb.com/vba-reference/

相关问题
最新问题