Excel-VBA zu PB-DLL: Übergabe eines Double-Arrays klappt nicht

[Klangtaucher]

Hallo Forum,

Folgendes Problem:

Ich versuche unter Win7-64Bit mit Excel2000 via VBA einer Pure-Basic-DLL einen Array mit Doubles zu übergeben. Ein Zeiger kommt wohl an, als Wert wird aber immer Null zurückgegeben.

Kann mir bitte jemand auf die Sprünge helfen, wo das Problem liegt ?

Danke für Eure Bemühungen

PB-Code:

Code: Alles auswählen

EnableExplicit

ProcedureDLL.d ArrayLesen(*PointerUebergabe)

Define Ergebnis.d
	Ergebnis.d = PeekD(*PointerUebergabe) 
	MessageRequester("Pointer", Str(*PointerUebergabe))
	ProcedureReturn  Ergebnis.d
EndProcedure

VBA-Code:

Code: Alles auswählen

Option Explicit
Declare Function ArrayLesen Lib "Pointer-Test.dll" (ByRef qwerty1() As Double) As Double


Function TestDouble(qwertz1 As Double)
    Dim TestArray(1) As Double
    
    TestArray(0) = 21
    TestArray(1) = 22
    
    TestDouble = ArrayLesen(TestArray())
End Function

[SMaag]

Da solltest du dich zuerst mit den sog. SafeArrays von Windows auseinandersetzen. Unter VB6 und VBA ist ein Array ein sog. SafeArray.
Es wird also nicht der Pointer direkt zu den Arraydaten übergeben, sondern der Pointer einer SafeArray-Struktur.
Siehe PB IDE TOOLS\StructureViewer. Dort findest du unter 's' die SAFEARRAY

Code: Alles auswählen

Structure SAFEARRAY
  cDims.w
  fFeatures.w
  cbElements.l
  cLocks.l
  PB_Alignment.b[4]
  *pvData.pData
  StructureUnion
  rgsabound.SAFEARRAYBOUND[0]
  dummyrgsabound.SAFEARRAYBOUND[1]
  EndStructureUnion
EndStructure

Diese Struktur ist in PB bereits vordefiniert.
Deine PB Procedure muss eine SafeArrayStructure annehmen.

Code: Alles auswählen

Procedure VBA_ARRAY(MyVbaArray.SAFEARRAY)
  
EndProcedure

[Klangtaucher]

Hallo SMaag,

danke für Deine Infos und Tipps.

Ich muss mir das Ganze in den nächsten Tagen mal in Ruhe anschauen.

Auf die Schnelle wirkt es auf mich recht komplex, mal schauen ob ich
als Anfänger damit zurechtkomme.

Grüße

[SMaag]

Hier noch ein Thread im englischen Forum zu SafeArray

https://www.purebasic.fr/english/viewtopic.php?t=30583


die Bedeutung fFeatures.w

Code: Alles auswählen

FADF_AUTO 	&H1 	Das Array liegt im Stack
FADF_STATIC 	&H2 	Ein statisches Array
FADF_EMBEDDED 	&H4 	Das Feld ist in einer Struktur eingebettet
FADF_FIXEDSIZE 	&H10 	Die Grenzen des Arrays sind nicht änderbar
FADF_RECORD 	&H20 	Das Array enthält Records
FADF_HAVEIID 	&H40 	Array über eine IID-Schnittstelle identifizierbar ist
FADF_HAVEVARTYPE 	&H80 	Feld des Typs VT
FADF_BSTR 	&H100 	String-Array
FADF_UNKNOWN 	&H200 	Array der Schnittstelle IUnknown
FADF_DISPATCH 	&H400 	Array der Schnittstelle IDispatch
FADF_VARIANT 	&H800 	Array ist vom Typ Variant

jetzt hab ich es auch bei activevb wieder gefunden

https://www.activevb.de/tutorials/tut_s ... array.html

[Klangtaucher]

Hey Merci,

oder doch besser Mercy ?

Ich glaube zu erahnen um was es geht.....
Aber mal sehen....

Grüße

[SMaag]

Was hast du mit den Arrays aus Excel vor?

Wir haben auf ActiveVB vor vielen Jahren mal einiges an Code für SafeArrays in VB6 geschrieben. Damit kann man einige Dinge machen, die in VB, VBA nicht direkt gehen. Z.B. eine 2te SafeArray-Struktur auf ein bestehendes Array legen, so dass man die Daten praktisch wie mit Union als 2 versschiedene Datentypen interpretieren kann.
Das läuft alles auch direkt in VBA. Wenn dir das was hilft kann ich mal versuchen das zu finden.

[Klangtaucher]

Hallo SMaag,

ich habe im Laufe meines Berufslebens in VBA sehr, sehr viele benutzerdefinierte Formeln geschrieben, die ich für bauphysikalische Berechnungen nutze und die eigenes Know-how enthalten. Die Algorithmen werden immer umfangreicher und komplexer und die Berechnungsergebnisse, die ich mit Messwerten vergleiche, immer genauer. Excel ist die Basis, die ich für interne Berechnungen nutze und auch weiterhin nutzen werde.

So langsam spiele ich aber mit dem Gedanken, ein PB-Programm zu schreiben und mein erarbeitetes Know-How zu vermarkten. Also bin ich dazu übergegangen, PB-DLL's zu schreiben, damit ich Code nicht doppelt schreiben muss. Ich kann dadurch wie gewohnt Berechnungen in Excel durchführen und gleichzeitig stehen mir die Algorithmen in PB für ein zukünftiges Programm zur Verfügung.
Allerdings macht in VBA die Parameter-Übergabe nicht wirklich Spaß. Bis dato hatte ich Formeln mit bis zu 32 Parametern. Das ist recht nervig und fummlig. Arrays zu übergeben wäre deutlich einfacher.

Als willkommener Nebeneffekt ist in Excel, wenn man z.B. eine Formel runterzieht und auf einen Schlag ein- oder zweitausend Berechnungen durchführt, PB-DLL-Code deutlich schneller als VBA-Code.

Was Du mir anbietest, verstehe ich nicht ganz. Falls mir dein Angebot hilft, einen oder mehrere Arrays (von Bedeutung sind eigentlich nur Arrays die Doubles enthalten) an eine DLL übergeben zu können, würde ich dein Angebot gerne annehmen. In der DLL werden dann die entsprechenden Berechnungen durchgeführt und in der Regel nur eine Zahl (als Double) an Excel zurückgegeben.

Grüße

[mk-soft]

Da ist noch viel zu lernen mit Variant und SafeArray ...

Ich bin mir nicht sicher ob VBA ein SafeArray übergibt oder ein Variant mit SafeArray ...

Ungetestet da hier kein Excel ?

Update

Code: Alles auswählen

EnableExplicit

IncludeFile "VariantHelper_Include.pb"

ProcedureDLL.d ArrayLesen(*psa.SAFEARRAY)
  Protected r1.d, cnt, index, lbound, ubound
  
  If saGetVartype(*psa) & #VT_R8
    cnt = saCount(*psa)
    MessageRequester("Info" , "Elemente = " + cnt)
    lbound = saLBound(*psa)
    ubound = saUBound(*psa)
    For index = lbound To ubound
      r1 + SA_DOUBLE(*psa, index)
    Next
  Else
    MessageRequester("Info", "Is not double")
  EndIf
  ProcedureReturn  r1
EndProcedure

VariantHelper_Include.pb

Code: Alles auswählen

;-TOP
; Kommentar     : Variant Helper
; Author        : mk-soft
; Second Author : ts-soft
; Datei         : VariantHelper_Include.pb
; Version       : 2.13
; Erstellt      : 30.04.2007
; Geändert      : 12.06.2018, 27.04.2023
;
; Compilermode  :
;
; ***************************************************************************************
;
; Informations:
;
; SafesArray functions and macros supported only array with one dims
;
;
;
;
; ***************************************************************************************

Global.l vhLastError, saLastError


; ***************************************************************************************

CompilerIf #PB_Compiler_Processor = #PB_Processor_x86
  Import "oleaut32.lib"
    SafeArrayAllocDescriptorEx(a.l,b.l,c.l) As "_SafeArrayAllocDescriptorEx@12"
    SafeArrayGetVartype(a.l,b.l) As "_SafeArrayGetVartype@8"
  EndImport
CompilerElse
  Import "oleaut32.lib"
    SafeArrayAllocDescriptorEx(a.i,b.i,c.i)
    SafeArrayGetVartype(a.i,b.i)
  EndImport
CompilerEndIf

; ***************************************************************************************

;- Structure SAFEARRAY
CompilerIf Defined(SAFEARRAYBOUND, #PB_Structure) = 0
  Structure SAFEARRAYBOUND
    cElements.l
    lLbound.l
  EndStructure
CompilerEndIf

CompilerIf Defined(pData, #PB_Structure) = 0
  Structure pData
    StructureUnion
      llVal.q[0]
      lVal.l[0]
      bVal.b[0]
      iVal.w[0]
      fltVal.f[0]
      dblVal.d[0]
      boolVal.w[0]
      bool.w[0]
      scode.l[0]
      cyVal.l[0]
      date.d[0]
      bstrVal.i[0]
      varVal.VARIANT[0] ; Added ?
      Value.VARIANT[0]  ; Added ?
      *punkVal.IUnknown[0]
      *pdispVal.IDispatch[0]
      *parray[0]
      *pbVal.BYTE[0]
      *piVal.WORD[0]
      *plVal.LONG[0]
      *pllVal.QUAD[0]
      *pfltVal.FLOAT[0]
      *pdblVal.DOUBLE[0]
      *pboolVal.LONG[0]
      *pbool.LONG[0]
      *pscode.LONG[0]
      *pcyVal.LONG[0]
      *pdate.DOUBLE[0]
      *pbstrVal.INTEGER[0]
      *ppunkVal.INTEGER[0]
      *ppdispVal.INTEGER[0]
      *pparray.INTEGER[0]
      *pvarVal.VARIANT[0]
      *byref[0]
      cVal.b[0]
      uiVal.w[0]
      ulVal.l[0]
      ullVal.q[0]
      intVal.l[0]
      uintVal.l[0]
      *pdecVal.LONG[0]
      *pcVal.BYTE[0]
      *puiVal.WORD[0]
      *pulVal.LONG[0]
      *pullVal.QUAD[0]
      *pintVal.LONG[0]
      *puintVal.LONG[0]
      decVal.l[0]
      brecord.VARIANT_BRECORD[0]
    EndStructureUnion
  EndStructure
CompilerEndIf

CompilerIf Defined(SAFEARRAY, #PB_Structure) = 0
  Structure SAFEARRAY
    cDims.w
    fFeatures.w
    cbElements.l
    cLocks.l
    *pvData.pData
    rgsabound.SAFEARRAYBOUND[0]
  EndStructure
CompilerEndIf

; ***************************************************************************************

;- Type Constants helps for Variant and SafeArray

#TLong = #VT_I4
#TQuad = #VT_I8
#TWord = #VT_I2
#TFloat = #VT_R4
#TDouble = #VT_R8
#TString = #VT_BSTR
#TDate = #VT_DATE

; ***************************************************************************************


;- Errorhandling

; ***************************************************************************************

Procedure.l vhGetLastError()
  
  Shared vhLastError
  
  ProcedureReturn vhLastError
  
EndProcedure

; ***************************************************************************************

Procedure.s vhGetLastMessage()
  
  Shared vhLastError
  
  Protected *Buffer, len, result.s
  
  len = FormatMessage_(#FORMAT_MESSAGE_ALLOCATE_BUFFER|#FORMAT_MESSAGE_FROM_SYSTEM,0,vhLastError,0,@*Buffer,0,0)
  If len
    result = PeekS(*Buffer)
    LocalFree_(*Buffer)
    ProcedureReturn result
  Else
    ProcedureReturn "Errorcode: " + Hex(vhLastError)
  EndIf
  
EndProcedure

; ***************************************************************************************

Procedure.l saGetLastError()
  
  Shared saLastError
  
  ProcedureReturn saLastError
  
EndProcedure

; ***************************************************************************************

Procedure.s saGetLastMessage()
  
  Shared saLastError
  
  Protected *Buffer, len, result.s
  
  len = FormatMessage_(#FORMAT_MESSAGE_ALLOCATE_BUFFER|#FORMAT_MESSAGE_FROM_SYSTEM,0,saLastError,0,@*Buffer,0,0)
  If len
    result = PeekS(*Buffer)
    LocalFree_(*Buffer)
    ProcedureReturn result
  Else
    ProcedureReturn "Errorcode: " + Hex(saLastError)
  EndIf
  
EndProcedure

; ***************************************************************************************


;- SafeArray Functions

; ***************************************************************************************

Procedure saCreateSafeArray(vartype, Lbound, Elements)
  
  Shared saLastError
  
  Protected rgsabound.SAFEARRAYBOUND, *psa
  
  rgsabound\lLbound = Lbound
  rgsabound\cElements = Elements
  saLastError = 0
  
  *psa = SafeArrayCreate_(vartype, 1, rgsabound)
  If *psa
    ProcedureReturn *psa
  Else
    saLastError = #E_OUTOFMEMORY
    ProcedureReturn 0
  EndIf
  
EndProcedure


; ***************************************************************************************

Procedure saFreeSafeArray(*psa.SAFEARRAY)
  
  Shared saLastError
  
  Protected hr
  
  saLastError = 0
  
  hr = SafeArrayDestroy_(*psa)
  If hr = #S_OK
    ProcedureReturn #True
  Else
    saLastError = hr
    ProcedureReturn #False
  EndIf
  
EndProcedure


; ***************************************************************************************

Procedure saGetVartype(*psa)
  
  Shared saLastError
  
  Protected hr, vartype
  
  saLastError = 0
  
  hr = SafeArrayGetVartype(*psa, @vartype)
  If hr = #S_OK
    ProcedureReturn vartype
  Else
    saLastError = hr
    ProcedureReturn 0
  EndIf
  
EndProcedure

; ***************************************************************************************

Procedure.l saCount(*psa.safearray) ; Result Count of Elements
  
  Protected result.l
  
  If *psa
    result = *psa\rgsabound\cElements
  Else
    result = 0
  EndIf
  
  ProcedureReturn result
  
EndProcedure

; ***************************************************************************************

Procedure.l saLBound(*psa.safearray) ; Result first number of Array
  
  Shared saLastError
  
  Protected hr, result
  
  saLastError = 0
  
  hr = SafeArrayGetLBound_(*psa, 1, @result)
  If hr = #S_OK
    ProcedureReturn result
  Else
    saLastError = hr
    ProcedureReturn 0
  EndIf
  
EndProcedure

; ***************************************************************************************

Procedure.l saUBound(*psa.safearray) ; Result last number of Array
  
  Shared saLastError
  
  Protected hr, result
  
  saLastError = 0
  
  hr = SafeArrayGetUBound_(*psa, 1, @result)
  If hr = #S_OK
    ProcedureReturn result
  Else
    saLastError = hr
    ProcedureReturn 0
  EndIf
  
EndProcedure

; ***************************************************************************************


;- Type Conversion Helper

; ***************************************************************************************

;-T_BSTR
Procedure helpSysAllocString(*Value)
  ProcedureReturn SysAllocString_(*Value)
EndProcedure
Prototype.l ProtoSysAllocString(Value.p-unicode)

Global T_BSTR.ProtoSysAllocString = @helpSysAllocString()

; ***************************************************************************************

Procedure.d T_DATE(pbDate) ; Result Date from PB-Date
  
  Protected date.d
  
  date = pbDate / 86400.0 + 25569.0
  ProcedureReturn date
  
EndProcedure

; ***************************************************************************************

Procedure T_BOOL(Assert) ; Result Variant Type Boolean
  
  If Assert
    ProcedureReturn #VARIANT_TRUE
  Else
    ProcedureReturn #VARIANT_FALSE
  EndIf
  
EndProcedure

; ***************************************************************************************

;- Memory Gabage

Procedure VariantClear(*Var.variant)
  
  Protected hr
  
  If *Var\vt & #VT_ARRAY = #VT_ARRAY
    hr =  SafeArrayDestroy_(*Var\parray)
    If hr = #S_OK
      *Var\parray = 0
      *var\vt = #VT_EMPTY
    EndIf
    ProcedureReturn hr
  Else
    ProcedureReturn VariantClear_(*Var)
  EndIf
  
EndProcedure

; ***************************************************************************************


;- Conversion Variant to PB Values

; ***************************************************************************************

Procedure.s VT_STR(*Var.Variant)
  
  Shared vhLastError.l
  
  Protected hr.l, result.s, VarDest.Variant
  
  vhLastError = 0
  
  If *Var
    hr = VariantChangeType_(VarDest, *Var, 0, #VT_BSTR)
    If hr = #S_OK
      result = PeekS(VarDest\bstrVal, #PB_Any, #PB_Unicode)
      VariantClear(VarDest)
      ProcedureReturn result
      
    Else
      vhLastError = hr
      ProcedureReturn ""
    EndIf
    
  EndIf
EndProcedure

; ***************************************************************************************

Procedure.l VT_BOOL(*Var.Variant)
  
  Shared vhLastError.l
  
  Protected hr.l, result.l, VarDest.Variant
  
  vhLastError = 0
  
  If *Var
    hr = VariantChangeType_(VarDest, *Var, 0, #VT_BOOL)
    If hr = #S_OK
      result = VarDest\boolVal
      VariantClear(VarDest)
      If result
        ProcedureReturn #True
      Else
        ProcedureReturn #False
      EndIf
      
    Else
      vhLastError = hr
      ProcedureReturn 0
    EndIf
    
  EndIf
  
EndProcedure

; ***************************************************************************************

Procedure.b VT_BYTE(*Var.Variant)
  
  Shared vhLastError.l
  
  Protected hr.l, result.b, VarDest.Variant
  
  vhLastError = 0
  
  If *Var
    hr = VariantChangeType_(VarDest, *Var, 0, #VT_I1)
    If hr = #S_OK
      result = VarDest\bVal
      VariantClear(VarDest)
      ProcedureReturn result
      
    Else
      vhLastError = hr
      ProcedureReturn 0
    EndIf
    
  EndIf
  
EndProcedure

; ***************************************************************************************

Procedure.w VT_WORD(*Var.Variant)
  
  Shared vhLastError.l
  
  Protected hr.l, result.w, VarDest.Variant
  
  vhLastError = 0
  
  If *Var
    hr = VariantChangeType_(VarDest, *Var, 0, #VT_I2)
    If hr = #S_OK
      result = VarDest\iVal
      VariantClear(VarDest)
      ProcedureReturn result
      
    Else
      vhLastError = hr
      ProcedureReturn 0
    EndIf
    
  EndIf
  
EndProcedure

; ***************************************************************************************

Procedure.l VT_LONG(*Var.Variant)
  
  Shared vhLastError.l
  
  Protected hr.l, result.l, VarDest.Variant
  
  vhLastError = 0
  
  If *Var
    hr = VariantChangeType_(VarDest, *Var, 0, #VT_I4)
    If hr = #S_OK
      result = VarDest\lVal
      VariantClear(VarDest)
      ProcedureReturn result
      
    Else
      vhLastError = hr
      ProcedureReturn 0
    EndIf
    
  EndIf
  
EndProcedure

; ***************************************************************************************

Procedure.q VT_QUAD(*Var.Variant)
  
  Shared vhLastError.l
  
  Protected hr.l, result.q, VarDest.Variant
  
  vhLastError = 0
  
  If *Var
    hr = VariantChangeType_(VarDest, *Var, 0, #VT_I8)
    If hr = #S_OK
      result = VarDest\llVal
      VariantClear(VarDest)
      ProcedureReturn result
      
    Else
      vhLastError = hr
      ProcedureReturn 0
    EndIf
    
  EndIf
  
EndProcedure

; ***************************************************************************************

Procedure.f VT_FLOAT(*Var.Variant)
  
  Shared vhLastError.l
  
  Protected hr.l, result.f, VarDest.Variant
  
  vhLastError = 0
  
  If *Var
    hr = VariantChangeType_(VarDest, *Var, 0, #VT_R4)
    If hr = #S_OK
      result = VarDest\fltVal
      VariantClear(VarDest)
      ProcedureReturn result
      
    Else
      vhLastError = hr
      ProcedureReturn 0
    EndIf
    
  EndIf
  
EndProcedure

; ***************************************************************************************

Procedure.d VT_DOUBLE(*Var.Variant)
  
  Shared vhLastError.l
  
  Protected hr.l, result.d, VarDest.Variant
  
  vhLastError = 0
  
  If *Var
    hr = VariantChangeType_(VarDest, *Var, 0, #VT_R8)
    If hr = #S_OK
      result = VarDest\dblVal
      VariantClear(VarDest)
      ProcedureReturn result
      
    Else
      vhLastError = hr
      ProcedureReturn 0
    EndIf
    
  EndIf
  
EndProcedure

; ***************************************************************************************

Procedure.l VT_DATE(*Var.Variant) ; Result PB-Date from Variant Date
  
  Shared vhLastError.l
  
  Protected pbDate
  
  Protected hr.l, result.d, VarDest.Variant
  
  vhLastError = 0
  
  If *Var
    hr = VariantChangeType_(VarDest, *Var, 0, #VT_DATE)
    If hr = #S_OK
      pbDate = (VarDest\dblVal  - 25569.0) * 86400.0
      VariantClear(VarDest)
      ProcedureReturn pbDate
    Else
      vhLastError = hr
      ProcedureReturn 0
    EndIf
    
  EndIf
  
EndProcedure

; ***************************************************************************************

Procedure.l VT_ARRAY(*Var.Variant) ; Result a Pointer to SafeArray
  
  Protected result.l
  
  vhLastError = 0
  
  If *Var
    If (*Var\vt & #VT_ARRAY) = #VT_ARRAY
      result = *Var\parray
    Else
      result = 0
    EndIf
  Else
    result = 0
  EndIf
  ProcedureReturn result
  
EndProcedure

; ***************************************************************************************


;- Converions PB Values to Variant

; ***************************************************************************************

Macro V_EMPTY(Arg)
  VariantClear(Arg)
EndMacro

; ***************************************************************************************

Macro V_NULL(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_NULL
  Arg\llVal
EndMacro

; ***************************************************************************************

Macro V_DISP(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_DISPATCH
  Arg\ppdispVal
EndMacro

; ***************************************************************************************

Macro V_UNKNOWN(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_UNKNOWN
  Arg\punkVal
EndMacro

; ***************************************************************************************

Macro V_STR(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_BSTR
  Arg\bstrVal
EndMacro

; ***************************************************************************************

Macro V_BOOL(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_BOOL
  Arg\boolVal
EndMacro

; ***************************************************************************************

Macro V_BYTE(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_I1
  Arg\bVal
EndMacro

; ***************************************************************************************

Macro V_UBYTE(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_UI1
  Arg\bVal
EndMacro

; ***************************************************************************************

Macro V_WORD(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_I2
  Arg\iVal
EndMacro

; ***************************************************************************************

Macro V_UWORD(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_UI2
  Arg\iVal
EndMacro

; ***************************************************************************************

Macro V_LONG(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_I4
  Arg\lVal
EndMacro

; ***************************************************************************************

Macro V_ULONG(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_UI4
  Arg\lVal
EndMacro

; ***************************************************************************************

Macro V_QUAD(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_I8
  Arg\llVal
EndMacro

; ***************************************************************************************

Macro V_FLOAT(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_R4
  Arg\fltVal
EndMacro

; ***************************************************************************************

Macro V_DOUBLE(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_R8
  Arg\dblVal
EndMacro

; ***************************************************************************************

Macro V_DATE(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_DATE
  Arg\dblVal
EndMacro

; ***************************************************************************************

Macro V_VARIANT(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_VARIANT
  Arg\pvarVal
EndMacro

; ***************************************************************************************
Macro V_NULL_BYREF(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_BYREF | #VT_NULL
  Arg\pllVal
EndMacro

; ***************************************************************************************

Macro V_DISP_BYREF(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_BYREF | #VT_DISPATCH
  Arg\ppdispVal
EndMacro

; ***************************************************************************************

Macro V_UNKNOWN_BYREF(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_BYREF | #VT_UNKNOWN
  Arg\ppunkVal
EndMacro

; ***************************************************************************************

Macro V_STR_BYREF(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_BYREF | #VT_BSTR
  Arg\pbstrVal
EndMacro

; ***************************************************************************************

Macro V_BOOL_BYREF(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_BYREF | #VT_BOOL
  Arg\pboolVal
EndMacro

; ***************************************************************************************

Macro V_BYTE_BYREF(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_BYREF | #VT_I1
  Arg\pbVal
EndMacro

; ***************************************************************************************

Macro V_UBYTE_BYREF(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_BYREF | #VT_UI1
  Arg\pbVal
EndMacro

; ***************************************************************************************

Macro V_WORD_BYREF(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_BYREF | #VT_I2
  Arg\piVal
EndMacro

; ***************************************************************************************

Macro V_UWORD_BYREF(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_BYREF | #VT_UI2
  Arg\piVal
EndMacro

; ***************************************************************************************

Macro V_LONG_BYREF(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_BYREF | #VT_I4
  Arg\plVal
EndMacro

; ***************************************************************************************

Macro V_ULONG_BYREF(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_BYREF | #VT_UI4
  Arg\plVal
EndMacro

; ***************************************************************************************

Macro V_QUAD_BYREF(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_BYREF | #VT_I8
  Arg\pllVal
EndMacro

; ***************************************************************************************

Macro V_FLOAT_BYREF(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_BYREF | #VT_R4
  Arg\pfltVal
EndMacro

; ***************************************************************************************

Macro V_DOUBLE_BYREF(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_BYREF | #VT_R8
  Arg\pdblVal
EndMacro

; ***************************************************************************************

Macro V_DATE_BYREF(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_BYREF | #VT_DATE
  Arg\pdblVal
EndMacro

; ***************************************************************************************


;- Conversion SafeArray

; ***************************************************************************************

Macro V_ARRAY_DISP(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_ARRAY |#VT_DISPATCH
  Arg\ppdispVal
EndMacro

; ***************************************************************************************

Macro V_ARRAY_STR(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_ARRAY | #VT_BSTR
  Arg\parray
EndMacro

; ***************************************************************************************

Macro V_ARRAY_BOOL(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_ARRAY | #VT_BOOL
  Arg\parray
EndMacro

; ***************************************************************************************

Macro V_ARRAY_BYTE(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_ARRAY | #VT_I1
  Arg\parray
EndMacro

; ***************************************************************************************

Macro V_ARRAY_UBYTE(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_ARRAY | #VT_UI1
  Arg\parray
EndMacro

; ***************************************************************************************

Macro V_ARRAY_WORD(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_ARRAY | #VT_I2
  Arg\parray
EndMacro

; ***************************************************************************************

Macro V_ARRAY_UWORD(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_ARRAY | #VT_UI2
  Arg\parray
EndMacro

; ***************************************************************************************

Macro V_ARRAY_LONG(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_ARRAY | #VT_I4
  Arg\parray
EndMacro

; ***************************************************************************************

Macro V_ARRAY_ULONG(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_ARRAY | #VT_UI4
  Arg\parray
EndMacro

; ***************************************************************************************

Macro V_ARRAY_QUAD(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_ARRAY | #VT_I8
  Arg\parray
EndMacro

; ***************************************************************************************

Macro V_ARRAY_FLOAT(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_ARRAY | #VT_R4
  Arg\parray
EndMacro

; ***************************************************************************************

Macro V_ARRAY_DOUBLE(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_ARRAY | #VT_R8
  Arg\parray
EndMacro

; ***************************************************************************************

Macro V_ARRAY_DATE(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_ARRAY | #VT_DATE
  Arg\parray
EndMacro

Macro V_ARRAY_VARIANT(Arg)
  VariantClear(Arg)
  Arg\vt = #VT_ARRAY | #VT_VARIANT
  Arg\parray
EndMacro

; ***************************************************************************************


;- Macros for Safearray to get and put values

; ***************************************************************************************

Macro SA_BYTE(psa, index)
  psa#\pvData\bVal[index-psa#\rgsabound\lLbound]
EndMacro

; ***************************************************************************************

Macro SA_WORD(psa, index)
  psa#\pvData\iVal[index-psa#\rgsabound\lLbound]
EndMacro

; ***************************************************************************************

Macro SA_LONG(psa, index)
  psa#\pvData\lVal[index-psa#\rgsabound\lLbound]
EndMacro

; ***************************************************************************************

Macro SA_FLOAT(psa, index)
  psa#\pvData\fltVal[index-psa#\rgsabound\lLbound]
EndMacro

; ***************************************************************************************

Macro SA_DOUBLE(psa, index)
  psa#\pvData\dblVal[index-psa#\rgsabound\lLbound]
EndMacro

; ***************************************************************************************

Macro SA_DATE(psa, index)
  psa#\pvData\dblVal[index-psa#\rgsabound\lLbound]
EndMacro

; ***************************************************************************************

Macro SA_BSTR(psa, index)
  psa#\pvData\bStrVal[index-psa#\rgsabound\lLbound]
EndMacro

; ***************************************************************************************

Procedure.s SA_STR(*psa.safearray, index) ; Result PB-String from SafeArray BSTR
  Protected *BSTR
  *BSTR = *psa\pvData\bStrVal[index-*psa\rgsabound\lLbound]
  ProcedureReturn PeekS(*BSTR, #PB_Any, #PB_Unicode)
EndProcedure

; ***************************************************************************************

Macro SA_VARIANT(psa, index)
  psa#\pvData\Value[index-psa#\rgsabound\lLbound]
EndMacro

; ***************************************************************************************

Macro SA_DISPATCH(psa, index)
  psa#\pvData\pdispVal[index-psa#\rgsabound\lLbound]
EndMacro

; ***************************************************************************************

[Klangtaucher]

Hallo mk-soft,

danke für deinen Code.
Ich bekomme die Meldung "Is not double".

Da ich nur Bahnhof verstehe, habe ich keine Möglichkeit zielführend an deinem Code rumzufummeln.

Da ist noch viel zu viel zu lernen mit PB auf elektrischen Glaskugeln......


Grüße

[mk-soft]

Mehr info

Code: Alles auswählen

EnableExplicit

IncludeFile "VariantHelper_Include.pb"

ProcedureDLL.d ArrayLesen(*psa.SAFEARRAY)
  Protected r1.d, cnt, index, lbound, ubound, type
  
  type = saGetVartype(*psa)
  If type
    MessageRequester("Info" , "Type = " + Hex(type))
    
    If saGetVartype(*psa) & #VT_R8
      cnt = saCount(*psa)
      lbound = saLBound(*psa)
      ubound = saUBound(*psa)
      For index = lbound To ubound
        r1 + SA_DOUBLE(*psa, index)
      Next
      MessageRequester("Info" , "Elemente = " + cnt + " Sum = " + r1)
    EndIf
  Else
    MessageRequester("Info", "Is not double" + #LF$ + saGetLastMessage())
  EndIf
  ProcedureReturn  r1
EndProcedure