Code: Select all
#Include once"win/ocidl.bi"
#Include Once "crt/string.bi"
'#include Once "win/olectl.bi" ' contient DllRegisterServer
#define W2Ansi(A,W) WideCharToMultiByte(CP_ACP,0,W,-1,A,2047,0,0)
#define A2Wide(A,W,L) MultiByteToWideChar(CP_ACP,0,A,-1,W,L)
#define CompareIID(A,B) memcmp (A,B,sizeof (GUID))
#define VBTRUE -1
#define GetInterface(A,B,C) A->lpVtbl->QueryInterface(A, cast(REFIID,@IID_##B), Cast(LPVOID Ptr, @C))
#define IRelease(A) A->lpVtbl->Release(A)
type As IFontDisp Font
type As IPictureDisp Picture
Declare Function ConvertAnsiStrToBStr(szAnsiIn As LPCSTR ,lpBstrOut As BSTR Ptr )As HRESULT
Declare Function ConvertBStrToAnsiStr(bstrIn As BSTR ,lpszOut as LPSTR Ptr )As HRESULT
Declare Function StrToBSTR(ByVal cnv_string As String) As BSTR 'bon
Declare Function BSTRtoString(ByVal mbStr As BSTR)As String ' bon
Declare Function BSTRtoStr(ByVal mbStr As BSTR)As zString Ptr
Declare Function strTOzstr ( Byval s1 As String ) As Zstring Ptr
Declare Function zstrTOstr ( s1 As Zstring Ptr ) As String
Declare Function BSTRtozString(ByVal mbStr As BSTR)As zString Ptr
Declare Function zStringToBSTR(ByVal sp As ZString Ptr) As BSTR
Declare Function UnicodeToAnsi (ByVal szW As OLECHAR Ptr ) As String ' bon
Declare Function UnicodeToAnsi2(ByVal szW As BSTR ) As zString Ptr ' bon
Declare Function AnsiToUnicode(A As String) As OLECHAR Ptr
Declare Function ShowProperty (punkv As LPVOID , title As ZString Ptr)As HRESULT
Declare function RetIPict ( bm As LPVOID,imgtype As Integer)As IPictureDisp Ptr
Declare Function RetIFont (fnamme As ZString Ptr ,siz As Single ,wgt As Short ,Ital As BOOL ,Und As BOOL ,Strike As BOOL )As IFontDisp Ptr Ptr
Declare Function arrayDimCount OverLoad(array() As Integer) As Integer
Declare Function arrayDimCount (array() As Single) As Integer
Declare Function arrayDimCount (array() As Double) As Integer
Declare Function arrayDimCount (array() As String) As Integer
Declare Function arrayDimCount (array() As Short) As Integer
Declare Function arrayDimCount (array() As BSTR) As Integer
Declare Function arrayDimCount (array() As LONG) As Integer
Declare Function arrayDimCount (array() As Any Ptr) As Integer
Declare Function IsArray overload (A() As Double) As Integer
Declare Function IsArray (A() As Single) As Integer
Declare Function IsArray (A() As Integer) As Integer
Declare Function IsMatrix OverLoad(A() As Double) As Integer
Declare Function IsMatrix (A() As Single) As Integer
Declare Function IsMatrix (A() As Integer) As Integer
Declare Function getSafeArray OverLoad (vt As VARTYPE,n As LONG,m As Long, debutligne As ULong,debutcol As ULong=0) As SAFEARRAY Ptr
Declare Function getSafeArray (vt As VARTYPE,debut As ULong,n As Long) As SAFEARRAY Ptr
Declare Function getSafeArray_Ex OverLoad (vt As VARTYPE,n1 As LONG,m1 As Long, n2 As Long,m2 As Long) As SAFEARRAY Ptr
Declare Function getSafeArray_Ex (vt As VARTYPE,m1 As Long, m2 As Long,m3 As Long) As SAFEARRAY Ptr
Declare Function SafeArrayIsCreated(Mat As SAFEARRAY Ptr)As Integer
Declare Sub ArrayToSafeArray_Ex OverLoad (ByRef b As SAFEARRAY Ptr,A() As Double)
Declare Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As Single)
Declare Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As Integer)
Declare Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As Short)
Declare Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As Long)
Declare Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As BSTR)
Declare Sub ArrayToSafeArray_Ex OverLoad (ByRef b As SAFEARRAY Ptr,A() As Any Ptr)
Declare Sub ArrayToSafeArray OverLoad (ByRef P As SAFEARRAY Ptr,A() As Double)
Declare Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As Single)
Declare Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As LONG)
Declare Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As BSTR)
Declare Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As Short)
Declare Function ArrayToSafeArray (A() As Double)As SAFEARRAY Ptr
Declare Sub VectorToSafeArray OverLoad ( P As SAFEARRAY Ptr,A() As BSTR)
Declare Sub VectorToSafeArray OverLoad ( P As SAFEARRAY Ptr,A() As Long)
Declare Sub VectorToSafeArray OverLoad (ByRef b As SAFEARRAY Ptr,A() As Double)
Declare Sub VectorToSafeArray OverLoad (ByRef b As SAFEARRAY Ptr,A() As Single)
Declare Sub VectorToSafeArray OverLoad ( P As SAFEARRAY Ptr,A() As Short)
Declare Sub VectorToSafeArray (ByRef b As SAFEARRAY Ptr,A() As String)
Declare Sub VectorToSafeArray OverLoad ( P As SAFEARRAY Ptr,A() As Any Ptr)
Declare Sub SafeArrayToArray OverLoad ( A()As Double,P As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray ( A()As Single,P As SAFEARRAY Ptr)
Declare Sub SafeArrayTovector OverLoad ( A()As Double,ByRef P As SAFEARRAY Ptr)
Declare Sub SafeArrayTovector( mstr()As BSTR ,P As SAFEARRAY Ptr)
Declare Sub SafeArrayTovector ( A()As Single,ByRef P As SAFEARRAY Ptr)
Declare Sub SafeArrayToArray_Ex ( A()As Double,ByRef P As SAFEARRAY Ptr)
Declare Sub ArrayToVariant OverLoad (ByRef hauteur As VARIANT Ptr ,M() As Double)
Declare Function ArrayToVariant(A() As Double)As VARIANT
Declare Function ArrayToVariant(A() As Single)As VARIANT
Declare Function ArrayToVariant(A() As BSTR)As VARIANT
Declare Function ArrayToVariant(A() As Long)As VARIANT
Declare Function ArrayToVariant(A() As Short)As VARIANT
Declare Function ArrayToVariant(A() As BOOL)As VARIANT
Declare Function ArrayToVariant(A() As Any Ptr)As VARIANT
Declare Function ArrayToVariant(arrySrc() As String)As VARIANT
Declare Sub ArrayToVariant (pVariant As VARIANT Ptr , arrySrc() As BSTR)
Declare Sub ArrayToVariant (pVariant As VARIANT Ptr , arrySrc As BSTR Ptr, n As Integer)
Declare Sub ArrayToVariant (pVariant As VARIANT Ptr , arrySrc() As Any Ptr)
Declare Sub ArrayToVariantd(ByRef V As VARIANT ,A() As double)
Declare Sub VariantToArray OverLoad(M() As Double, V As VARIANT)
Declare Sub VariantToArray(M() As Single, V As VARIANT)
Declare Sub VariantToArray OverLoad(arrySrc() As BSTR,v As VARIANT )
Declare Sub VariantToArray(arrySrc() As String,v As VARIANT )
Declare Sub VariantPutElement(value As Any Ptr,i As Integer,j As Integer=0)
Declare Sub VariantToArray OverLoad(arrySrc() As Any Ptr,v As VARIANT )
Declare Sub SafeArrayTovector( mstr()As String ,P As SAFEARRAY Ptr)
Declare Sub VariantToSafeArray OverLoad (ByVal V As VARIANT ,ByRef P As SAFEARRAY ptr)
Declare Function VariantToSafeArray(ByVal V As VARIANT Ptr)As SAFEARRAY Ptr
Declare Function SafeArrayToVariant(ByVal P As SAFEARRAY Ptr)As VARIANT
Declare function VarArrayCreate(Bounds()As Integer,AVarType As VARTYPE)As VARIANT
Declare function VarArrayDimCount(A As Variant)As Integer
Declare Sub VarArrayRedim(ByRef A As Variant, HighBound As Integer)
Declare Function VarArrayLowBound( A as Variant, iDim as Integer)As Integer
Declare function VarArrayHighBound(A As Variant, iDim As Integer)as Integer
Declare function VarArrayLock(A As Variant) As Any Ptr
Declare Sub VarArrayUnlock(A as Variant)
Declare function VarIsArray( A As Variant)As Boolean
Declare SUB PrintMatrix OverLoad (ByVal Title AS STRING, A() AS DOUBLE)
Declare SUB PrintMatrix (ByVal Title AS STRING, A() AS Double, col1 As Integer,col2 As Integer)
Declare SUB PrintVector(ByVal Title AS STRING, B() AS DOUBLE)
Declare Function RoundFloat( Byval d As Double, Byval p As Integer ) As Double
'convert string to bstr
'please follow with sysfreestring(bstr) after use to avoid memory leak
Function StringToBSTR(cnv_string As String) As BSTR
Dim sb As BSTR
Dim As Integer n
n = (MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, NULL, 0))-1
sb=SysAllocStringLen(sb,n)
MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, sb, n)
Return sb
End Function
Function ConvertAnsiStrToBStr(szAnsiIn As LPCSTR ,lpBstrOut As BSTR Ptr )As HRESULT
Dim As DWORD dwSize
if (lpBstrOut = NULL) Then Return E_INVALIDARG
if (szAnsiIn = NULL) Then
*lpBstrOut = NULL
return NOERROR
EndIf
dwSize = MultiByteToWideChar(CP_ACP, 0, szAnsiIn, -1, NULL, 0)
if (dwSize = 0) then return HRESULT_FROM_WIN32( GetLastError() )
*lpBstrOut = SysAllocStringLen(NULL, dwSize - 1)
if (*lpBstrOut = NULL) Then Return E_OUTOFMEMORY
if ( 0=MultiByteToWideChar(CP_ACP, 0, szAnsiIn, -1, *lpBstrOut, dwSize) )Then
SysFreeString(*lpBstrOut)
return HRESULT_FROM_WIN32( GetLastError() )
End If
return NOERROR
End Function
Function ConvertBStrToAnsiStr(bstrIn As BSTR ,lpszOut as LPSTR Ptr )As HRESULT
Dim As DWORD dwSize
if (lpszOut = NULL) Then Return E_INVALIDARG
if (bstrIn = NULL)Then
*lpszOut = NULL
return NOERROR
EndIf
dwSize = WideCharToMultiByte(CP_ACP, 0, bstrIn, -1, NULL, 0, NULL, NULL)
if (dwSize = 0) Then Return HRESULT_FROM_WIN32( GetLastError() )
*lpszOut = Cast(LPSTR,SysAllocStringByteLen(NULL, dwSize - 1))
if (*lpszOut = NULL)then return E_OUTOFMEMORY
if ( 0=WideCharToMultiByte(CP_ACP, 0, bstrIn, -1, *lpszOut, dwSize, NULL, NULL) )Then
SysFreeString(Cast(BSTR,*lpszOut))
return HRESULT_FROM_WIN32( GetLastError() )
End If
return NOERROR
End Function
Function StrToBSTR(ByVal cnv_string As String) As BSTR
Dim sb As BSTR
Dim As Integer n
n = (MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, NULL, 0))-1
sb=SysAllocStringLen(sb,n)
MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, cnv_string, -1, sb, n)
Return sb
End Function
Function BSTRtoString(ByVal mbStr As BSTR)As String
Return UnicodeToAnsi(mbstr)
End Function
Function BSTRtoStr(ByVal mbStr As BSTR)As zString Ptr
Return UnicodeToAnsi2(mbstr)
End Function
Function strTOzstr ( Byval s1 As String ) As Zstring Ptr
Return StrPtr(s1 )
End Function
'-------------------------------------------------------------------------------
Function zstrTOstr ( s1 As Zstring Ptr ) As String
Return s1[0]
End Function
Function BSTRtozString(ByVal mbStr As BSTR)As zString Ptr
Dim s As String
s=BSTRtoString(mbstr)
Return Cast(ZString Ptr,@s)
End Function
Function zStringToBSTR(ByVal sp As ZString Ptr) As BSTR
Return StrToBSTR(*sp)
End Function
Function UnicodeToAnsi (ByVal szW As OLECHAR Ptr ) As String ' bon
Static szA As ZString*256
If szW=NULL Then Return ""
WideCharToMultiByte(CP_ACP,0,SzW,-1,SzA,256,NULL,NULL)
Return szA
End Function
Function UnicodeToAnsi2(ByVal szW As BSTR ) As zString Ptr ' bon
Static szA As ZString ptr
If szW=NULL Then Return NULL
WideCharToMultiByte(CP_ACP,0,SzW,-1,SzA,256,NULL,NULL)
Return szA
End Function
Function AnsiToUnicode(A As String) As OLECHAR Ptr
Dim W As OLECHAR Ptr
Dim length As Integer
length=(2 * Len(A)) + 1
A2Wide(StrPtr(A),W,length)
Return W
End Function
'******************************************************************************
' Helper Functions - General
'******************************************************************************
Function Cbstr (szIn As ZString Ptr,bfree As Integer=0)As BSTR Ptr
static as BSTR bStr(10)
static As integer index
Dim As Integer length
if(bfree)Then
for index=0 To 9
SysFreeString(bStr(index))
Next
return 0
End If
index+=1
if(index=10)then index=0
SysFreeString(bStr(index))
length=(2 * len(*szIn)) + 1
bStr(index)=SysAllocStringLen(NULL, length)
A2Wide(szIn,bStr(index),length)
return @bStr(index)
End Function
#Ifdef USECOM
#include "win/olectl.bi" ' contient DllRegisterServer
Function ShowProperty (punkv As LPVOID , title As ZString Ptr)As HRESULT
Dim As ISpecifyPropertyPages Ptr ptrproppages
Dim As CAUUID ca
memset(@ca,0,sizeof(CAUUID))
Dim As HRESULT hr
Dim As IUnknown ptr pUnk
pUnk=Cast(IUnknown Ptr,punkv)
' hr=GetInterface(pUnk, ISpecifyPropertyPages, ptrproppages)
pUnk->lpVtbl->QueryInterface(pUnk, cast(REFIID,@IID_ISpecifyPropertyPages), Cast(LPVOID Ptr, @ptrproppages))
if(hr<>S_OK) Then Return hr
hr=ptrproppages->lpVtbl->GetPages(ptrproppages,@ca)
if(hr<>S_OK) Then Return hr
hr=OleCreatePropertyFrame(GetActiveWindow(),30,30,*Cbstr(title),1,@pUnk,ca.cElems,ca.pElems,LOCALE_USER_DEFAULT,0,0)
CoTaskMemFree(ca.pElems)
IRelease(ptrproppages)
return hr
End Function
function RetIPict ( bm As LPVOID,imgtype As Integer)As IPictureDisp Ptr
static as IPictureDisp Ptr IPDisp
if(IPDisp)Then IRelease(IPDisp)
IPDisp=NULL
if(bm=NULL) Then return IPDisp
Static As PICTDESC pd
memset(@pd,0,sizeof(pd))
pd.cbSizeofstruct=sizeof(PICTDESC)
pd.picType=imgtype
if(imgtype=PICTYPE_BITMAP)Then
pd.bmp.hbitmap=Cast(HBITMAP,bm )
elseif(imgtype=PICTYPE_ICON)Then
pd.icon.hicon=Cast(HICON,bm)
else
return NULL
End If
OleCreatePictureIndirect(@pd,cast(REFIID,@IID_IPictureDisp),TRUE,cast(LPVOID Ptr,@IPDisp))
return IPDisp
End Function
Function RetIFont (fnamme As ZString Ptr ,siz As Single ,wgt As Short ,Ital As BOOL ,Und As BOOL ,Strike As BOOL )As IFontDisp Ptr Ptr
Dim As FONTDESC fd ' voir win/olectl.bi
static As IFontDisp Ptr IFDisp
if(IFDisp)Then IRelease(IFDisp)
if(fnamme=NULL)then
IFDisp=NULL
return NULL
End If
fd.cbSizeofstruct=sizeof(FONTDESC)
fd.lpstrName =*Cbstr(fnamme)
' ***PellesC users should change the next line to : fd.cySize.int64=siz*10000;
'fd.cySize=Cast(CY,(siz*10000))
fd.cySize.int64=siz*10000
fd.sWeight=wgt
fd.fItalic=Ital
fd.fUnderline=Und
fd.fStrikethrough=Strike
OleCreateFontIndirect(@fd,Cast(REFIID,@IID_IFontDisp),Cast(LPVOID Ptr,@IFDisp))
return @IFDisp
End Function
#EndIf
Function arrayDimCount OverLoad(array() As Integer) As Integer
Dim d As Integer
Asm
mov esi, [ebp+8]
mov eax, [esi+16]
mov [d], eax
End Asm
Return d
End Function
Function arrayDimCount (array() As Single) As Integer
Dim d As Integer
Asm
mov esi, [ebp+8]
mov eax, [esi+16]
mov [d], eax
End Asm
Return d
End Function
Function arrayDimCount (array() As Double) As Integer
Dim d As Integer
Asm
mov esi, [ebp+8]
mov eax, [esi+16]
mov [d], eax
End Asm
Return d
End Function
Function arrayDimCount (array() As String) As Integer
Dim d As Integer
Asm
mov esi, [ebp+8]
mov eax, [esi+16]
mov [d], eax
End Asm
Return d
End Function
Function arrayDimCount (array() As Short) As Integer
Dim d As Integer
Asm
mov esi, [ebp+8]
mov eax, [esi+16]
mov [d], eax
End Asm
Return d
End Function
Function arrayDimCount (array() As BSTR) As Integer
Dim d As Integer
Asm
mov esi, [ebp+8]
mov eax, [esi+16]
mov [d], eax
End Asm
Return d
End Function
Function arrayDimCount (array() As LONG) As Integer
Dim d As Integer
Asm
mov esi, [ebp+8]
mov eax, [esi+16]
mov [d], eax
End Asm
Return d
End Function
Function arrayDimCount (array() As Any Ptr) As Integer
Dim d As Integer
Asm
mov esi, [ebp+8]
mov eax, [esi+16]
mov [d], eax
End Asm
Return d
End Function
Function IsArray overload (A() As Double) As Integer
If arrayDimCount(A())=1 Then
Return 1
Else
Return 0
End If
End Function
Function IsArray (A() As Single) As Integer
If arrayDimCount(A())=1 Then
Return 1
Else
Return 0
End If
End Function
Function IsArray (A() As Integer) As Integer
If arrayDimCount(A())=1 Then
Return 1
Else
Return 0
End If
End Function
Function IsMatrix OverLoad(A() As Double) As Integer
If arrayDimCount(A())=1 Then
Return 0
Else
Return arrayDimCount(A())
End If
End Function
Function IsMatrix (A() As Single) As Integer
If arrayDimCount(A())=1 Then
Return 0
Else
Return arrayDimCount(A())
End If
End Function
Function IsMatrix (A() As Integer) As Integer
If arrayDimCount(A())=1 Then
Return 0
Else
Return arrayDimCount(A())
End If
End Function
Function getSafeArray OverLoad (vt As VARTYPE,n As LONG,m As Long, debutligne As ULong,debutcol As ULong=0) As SAFEARRAY Ptr
Dim a As SAFEARRAY Ptr
Dim aDims(0 To 1) As SAFEARRAYBOUND
aDims(0).lLbound=debutligne
aDims(0).cElements=n-debutligne+1
If m<>0 Then
aDims(1).lLbound=debutcol
aDims(1).cElements=m-debutcol+1
a=SafeArrayCreate(vt,2,@aDims(0))
Else
a=SafeArrayCreate(vt,1,@aDims(0))
EndIf
Return a
End Function
Function getSafeArray (vt As VARTYPE,debut As ULong,n As Long) As SAFEARRAY Ptr
Dim a As SAFEARRAY Ptr
Dim aDims(0 To 1) As SAFEARRAYBOUND
aDims(0).lLbound=debut
aDims(0).cElements=n -debut+1
a=SafeArrayCreate(vt,1,@aDims(0))
Return a
End Function
Function getSafeArray_Ex OverLoad (vt As VARTYPE,n1 As LONG,m1 As Long, n2 As Long,m2 As Long) As SAFEARRAY Ptr
Dim a As SAFEARRAY Ptr
Dim aDims(0 To 2) As SAFEARRAYBOUND
If (n1<>0 And m1<>0) Then
If (n2=0 And m2=0) Then
aDims(0).lLbound=n1
aDims(0).cElements=m1-n1+1
a=SafeArrayCreate(vt,1,@aDims(0))
Return a
End If
End If
If( n1<>0 And m1<>0) Then
If (n2<>0 And m2<>0) Then
aDims(0).lLbound=n1
aDims(0).cElements=m1-n1+1
aDims(1).lLbound=n2
aDims(1).cElements=m2-n2+1
a=SafeArrayCreate(vt,2,@aDims(0))
Return a
End If
End If
End Function
Function getSafeArray_Ex (vt As VARTYPE,m1 As Long, m2 As Long,m3 As Long) As SAFEARRAY Ptr
Dim a As SAFEARRAY Ptr
Dim aDims(0 To 2) As SAFEARRAYBOUND
aDims(0).lLbound=1
aDims(0).cElements=m1
aDims(1).lLbound=1
aDims(1).cElements=m2
aDims(2).lLbound=1
aDims(2).cElements=m3
a=SafeArrayCreate(vt,3,@aDims(0))
Return a
End Function
Function getSafeArray_Ex1 (vt As VARTYPE,n1 As LONG,m1 As Long, n2 As Long=0,m2 As Long=0,n3 As Long=0,m3 As Long=0) As SAFEARRAY Ptr
Dim a As SAFEARRAY Ptr
Dim aDims(0 To 2) As SAFEARRAYBOUND
If (n1<>0 And m1<>0) Then
If (n2=0 And m2=0) Then
If (n3=0 And m3=0) Then
aDims(0).lLbound=n1
aDims(0).cElements=m1
a=SafeArrayCreate(vt,1,@aDims(0))
Return a
End If
End If
End If
If( n1<>0 And m1<>0) Then
If (n2<>0 And m2<>0) Then
if (n3=0 And m3=0) Then
aDims(0).lLbound=n1
aDims(0).cElements=m1
aDims(1).lLbound=n2
aDims(1).cElements=m2
a=SafeArrayCreate(vt,2,@aDims(0))
Return a
End If
End If
End If
If(n1<>0 And m1<>0)Then
if (n2<>0 And m2<>0) Then
If (n3<>0 And m3<>0) Then
aDims(0).lLbound=n1
aDims(0).cElements=m1
aDims(1).lLbound=n2
aDims(1).cElements=m2
aDims(2).lLbound=n3
aDims(2).cElements=m3
a=SafeArrayCreate(vt,3,@aDims(0))
Return a
End If
End If
'Else
'MessageBox(GetActiveWindow(),"revoir les données","Erreur",MB_ICONERROR)
End If
End Function
Function SafeArrayIsCreated(Mat As SAFEARRAY Ptr)As Integer
Dim vt As VARTYPE
If SafeArrayGetVartype(Mat,@vt)=s_ok Then
Return 1
Else
Return 0
EndIf
End Function
Sub ArrayToSafeArray_Ex OverLoad (ByRef b As SAFEARRAY Ptr,A() As Double)
Dim As Integer i,j,k
Dim aDims(0 To 2) As SAFEARRAYBOUND
aDims(0).lLbound=LBound(A,1)
aDims(0).cElements=UBound(A,1)
aDims(1).lLbound=LBound(A,2)
aDims(1).cElements=UBound(A,2)
aDims(2).lLbound=LBound(A,3)
aDims(2).cElements=UBound(A,3)
If SafeArrayIsCreated(b)=1 Then
Else
b=SafeArrayCreate(VT_R8,3,@aDims(0))
End If
Dim bi(0 To 2) As Integer
For i=LBound(A,1) To UBound(A,1)
bi(0)=i
For j=LBound(A,2) To UBound(A,2)
bi(1)=j
For k=LBound(A,3) To UBound(A,3)
bi(2)=k
SafeArrayPutElement(b,@bi(0),@A(i,j,k))
Next
Next
Next
End Sub
Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As Single)
Dim As Integer i,j,k
Dim R As Double
Dim aDims(0 To 2) As SAFEARRAYBOUND
aDims(0).lLbound=LBound(A,1)
aDims(0).cElements=UBound(A,1)
aDims(1).lLbound=LBound(A,2)
aDims(1).cElements=UBound(A,2)
aDims(2).lLbound=LBound(A,3)
aDims(2).cElements=UBound(A,3)
If SafeArrayIsCreated(b)=1 Then
Else
b=SafeArrayCreate(VT_R8,3,@aDims(0))
End If
Dim bi(0 To 2) As Integer
For i=LBound(A,1) To UBound(A,1)
bi(0)=i
For j=LBound(A,2) To UBound(A,2)
bi(1)=j
For k=LBound(A,3) To UBound(A,3)
bi(2)=k
SafeArrayPutElement(b,@bi(0),@A(i,j,k))
Next
Next
Next
End Sub
Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As Integer)
Dim As Integer i,j,k
Dim aDims(0 To 2) As SAFEARRAYBOUND
aDims(0).lLbound=LBound(A,1)
aDims(0).cElements=UBound(A,1)
aDims(1).lLbound=LBound(A,2)
aDims(1).cElements=UBound(A,2)
aDims(2).lLbound=LBound(A,3)
aDims(2).cElements=UBound(A,3)
If SafeArrayIsCreated(b)=1 Then
Else
b=SafeArrayCreate(VT_I4,3,@aDims(0))
End If
Dim bi(0 To 2) As Integer
For i=LBound(A,1) To UBound(A,1)
bi(0)=i
For j=LBound(A,2) To UBound(A,2)
bi(1)=j
For k=LBound(A,3) To UBound(A,3)
bi(2)=k
SafeArrayPutElement(b,@bi(0),@A(i,j,k))
Next
Next
Next
End Sub
Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As SHORT)
Dim As Integer i,j,k
Dim aDims(0 To 2) As SAFEARRAYBOUND
aDims(0).lLbound=LBound(A,1)
aDims(0).cElements=UBound(A,1)
aDims(1).lLbound=LBound(A,2)
aDims(1).cElements=UBound(A,2)
aDims(2).lLbound=LBound(A,3)
aDims(2).cElements=UBound(A,3)
If SafeArrayIsCreated(b)=1 Then
Else
b=SafeArrayCreate(VT_I2,3,@aDims(0))
End If
Dim bi(0 To 2) As Integer
For i=LBound(A,1) To UBound(A,1)
bi(0)=i
For j=LBound(A,2) To UBound(A,2)
bi(1)=j
For k=LBound(A,3) To UBound(A,3)
bi(2)=k
SafeArrayPutElement(b,@bi(0),@A(i,j,k))
Next
Next
Next
End Sub
Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As Long)
Dim As Integer i,j,k
Dim aDims(0 To 2) As SAFEARRAYBOUND
aDims(0).lLbound=LBound(A,1)
aDims(0).cElements=UBound(A,1)
aDims(1).lLbound=LBound(A,2)
aDims(1).cElements=UBound(A,2)
aDims(2).lLbound=LBound(A,3)
aDims(2).cElements=UBound(A,3)
If SafeArrayIsCreated(b)=1 Then
Else
b=SafeArrayCreate(VT_I4,3,@aDims(0))
End If
Dim bi(0 To 2) As Integer
For i=LBound(A,1) To UBound(A,1)
bi(0)=i
For j=LBound(A,2) To UBound(A,2)
bi(1)=j
For k=LBound(A,3) To UBound(A,3)
bi(2)=k
SafeArrayPutElement(b,@bi(0),@A(i,j,k))
Next
Next
Next
End Sub
Sub ArrayToSafeArray_Ex (ByRef b As SAFEARRAY Ptr,A() As BSTR)
Dim As Integer i,j,k
Dim aDims(0 To 2) As SAFEARRAYBOUND
aDims(0).lLbound=LBound(A,1)
aDims(0).cElements=UBound(A,1)
aDims(1).lLbound=LBound(A,2)
aDims(1).cElements=UBound(A,2)
aDims(2).lLbound=LBound(A,3)
aDims(2).cElements=UBound(A,3)
If SafeArrayIsCreated(b)=1 Then
Else
b=SafeArrayCreate(VT_BSTR,3,@aDims(0))
End If
Dim bi(0 To 2) As Integer
For i=LBound(A,1) To UBound(A,1)
bi(0)=i
For j=LBound(A,2) To UBound(A,2)
bi(1)=j
For k=LBound(A,3) To UBound(A,3)
bi(2)=k
SafeArrayPutElement(b,@bi(0),@A(i,j,k))
Next k
Next j
Next i
End Sub
Sub ArrayToSafeArray_Ex OverLoad (ByRef b As SAFEARRAY Ptr,A() As Any Ptr)
Dim As Integer i,j,k
Dim aDims(0 To 2) As SAFEARRAYBOUND
aDims(0).lLbound=LBound(A,1)
aDims(0).cElements=UBound(A,1)
aDims(1).lLbound=LBound(A,2)
aDims(1).cElements=UBound(A,2)
aDims(2).lLbound=LBound(A,3)
aDims(2).cElements=UBound(A,3)
If SafeArrayIsCreated(b)=1 Then
Else
b=SafeArrayCreate(VT_VARIANT,3,@aDims(0))
End If
Dim bi(0 To 2) As Integer
For i=LBound(A,1) To UBound(A,1)
bi(0)=i
For j=LBound(A,2) To UBound(A,2)
bi(1)=j
For k=LBound(A,3) To UBound(A,3)
bi(2)=k
SafeArrayPutElement(b,@bi(0),@A(i,j,k))
Next k
Next j
Next i
End Sub
Sub ArrayToSafeArray OverLoad (ByRef P As SAFEARRAY Ptr,A() As Double)
Dim As Integer i,j,mdim =arrayDimCount(A())
Dim bi(0 To 1) As Integer
If SafeArrayIsCreated(P)=1 Then
Else
If mdim=3 Then
P=getSafeArray_Ex1 (VT_R8,LBound(A,1),UBound(A,1), LBound(A,2),UBound(A,2),LBound(A,3),UBound(A,3) )
ElseIf mdim=2 Then
P=getSafeArray_Ex(VT_R8,LBound(A,1),UBound(A,1),LBound(A,2),UBound(A,2))
ElseIf mdim=1 Then
P=getSafeArray(VT_R8,LBound(A,1),UBound(A,1))
EndIf
EndIf
If SafeArrayGetDim(P)=1 Then
'SafeArrayTovector(A(),P)
VectorToSafeArray(P,A())
ElseIf SafeArrayGetDim(P)=2 Then
For i=LBound(A,1) To UBound(A,1)
bi(0)=i
For j=LBound(A,2) To UBound(A,2)
bi(1)=j
SafeArrayPutElement(P,@bi(0),@A(i,j))
Next
Next
ElseIf SafeArrayGetDim(P)=3 Then
ArrayToSafeArray_Ex(P,A())
End If
End Sub
Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As Single)
Dim As Integer i,j,mdim =arrayDimCount(A())
Dim bi(0 To 1) As Integer
If SafeArrayIsCreated(P)=1 Then
Else
If mdim=3 Then
P=getSafeArray_Ex1 (VT_R4,LBound(A,1),UBound(A,1), LBound(A,2),UBound(A,2),LBound(A,3),UBound(A,3) )
ElseIf mdim=2 Then
P=getSafeArray_Ex(VT_R4,LBound(A,1),UBound(A,1),LBound(A,2),UBound(A,2))
ElseIf mdim=1 Then
P=getSafeArray(VT_R4,LBound(A,1),UBound(A,1))
EndIf
EndIf
If SafeArrayGetDim(P)=1 Then
VectorToSafeArray(P,A())
ElseIf SafeArrayGetDim(P)=2 Then
For i=LBound(A,1) To UBound(A,1)
bi(0)=i
For j=LBound(A,2) To UBound(A,2)
bi(1)=j
SafeArrayPutElement(P,@bi(0),@A(i,j))
Next
Next
ElseIf SafeArrayGetDim(P)=3 Then
ArrayToSafeArray_Ex(P,A())
End If
End Sub
Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As LONG)
Dim As Integer i,j,mdim =arrayDimCount(A())
Dim bi(0 To 1) As Integer
If SafeArrayIsCreated(P)=1 Then
Else
If mdim=3 Then
P=getSafeArray_Ex1 (VT_I4,LBound(A,1),UBound(A,1), LBound(A,2),UBound(A,2),LBound(A,3),UBound(A,3) )
ElseIf mdim=2 Then
P=getSafeArray_Ex(VT_I4,LBound(A,1),UBound(A,1),LBound(A,2),UBound(A,2))
ElseIf mdim=1 Then
P=getSafeArray(VT_I4,LBound(A,1),UBound(A,1))
EndIf
EndIf
If SafeArrayGetDim(P)=1 Then
VectorToSafeArray(P,A())
ElseIf SafeArrayGetDim(P)=2 Then
For i=LBound(A,1) To UBound(A,1)
bi(0)=i
For j=LBound(A,2) To UBound(A,2)
bi(1)=j
SafeArrayPutElement(P,@bi(0),@A(i,j))
Next
Next
ElseIf SafeArrayGetDim(P)=3 Then
ArrayToSafeArray_Ex(P,A())
End If
End Sub
Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As Short)
Dim As Integer i,j,mdim =arrayDimCount(A())
Dim bi(0 To 1) As Integer
If SafeArrayIsCreated(P)=1 Then
Else
If mdim=3 Then
P=getSafeArray_Ex1 (VT_I2,LBound(A,1),UBound(A,1), LBound(A,2),UBound(A,2),LBound(A,3),UBound(A,3) )
ElseIf mdim=2 Then
P=getSafeArray_Ex(VT_I2,LBound(A,1),UBound(A,1),LBound(A,2),UBound(A,2))
ElseIf mdim=1 Then
P=getSafeArray(VT_I2,LBound(A,1),UBound(A,1))
EndIf
EndIf
If SafeArrayGetDim(P)=1 Then
VectorToSafeArray(P,A())
ElseIf SafeArrayGetDim(P)=2 Then
For i=LBound(A,1) To UBound(A,1)
bi(0)=i
For j=LBound(A,2) To UBound(A,2)
bi(1)=j
SafeArrayPutElement(P,@bi(0),@A(i,j))
Next
Next
ElseIf SafeArrayGetDim(P)=3 Then
ArrayToSafeArray_Ex(P,A())
End If
End Sub
Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As Any Ptr)
Dim As Integer i,j,mdim =arrayDimCount(A())
Dim bi(0 To 1) As Integer
'NB:A() must Handle BSTR not string
If SafeArrayIsCreated(P)=1 Then
Else
If mdim=3 Then
P=getSafeArray_Ex1 (VT_VARIANT,LBound(A,1),UBound(A,1), LBound(A,2),UBound(A,2),LBound(A,3),UBound(A,3) )
ElseIf mdim=2 Then
P=getSafeArray_Ex(VT_VARIANT,LBound(A,1),UBound(A,1),LBound(A,2),UBound(A,2))
ElseIf mdim=1 Then
P=getSafeArray(VT_VARIANT,LBound(A,1),UBound(A,1))
EndIf
EndIf
If SafeArrayGetDim(P)=1 Then
VectorToSafeArray(P,A())
ElseIf SafeArrayGetDim(P)=2 Then
For i=LBound(A,1) To UBound(A,1)
bi(0)=i
For j=LBound(A,2) To UBound(A,2)
bi(1)=j
SafeArrayPutElement(P,@bi(0),@A(i,j))
Next
Next
ElseIf SafeArrayGetDim(P)=3 Then
ArrayToSafeArray_Ex(P,A())
End If
End Sub
Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As BSTR)
Dim As Integer i,j,mdim =arrayDimCount(A())
Dim bi(0 To 1) As Integer
If SafeArrayIsCreated(P)=1 Then
Else
If mdim=3 Then
P=getSafeArray_Ex1 (VT_BSTR,LBound(A,1),UBound(A,1), LBound(A,2),UBound(A,2),LBound(A,3),UBound(A,3) )
ElseIf mdim=2 Then
P=getSafeArray_Ex(VT_BSTR,LBound(A,1),UBound(A,1),LBound(A,2),UBound(A,2))
ElseIf mdim=1 Then
P=getSafeArray(VT_BSTR,LBound(A,1),UBound(A,1))
EndIf
EndIf
If SafeArrayGetDim(P)=1 Then
VectorToSafeArray(P,A())
ElseIf SafeArrayGetDim(P)=2 Then
For i=LBound(A,1) To UBound(A,1)
bi(0)=i
For j=LBound(A,2) To UBound(A,2)
bi(1)=j
SafeArrayPutElement(P,@bi(0),@A(i,j))
Next
Next
ElseIf SafeArrayGetDim(P)=3 Then
ArrayToSafeArray_Ex(P,A())
End If
End Sub
Function ArrayToSafeArray (A() As Double)As SAFEARRAY Ptr
Dim As Integer i,j,mdim =arrayDimCount(A())
Dim bi(0 To 1) As Integer
Dim P As SAFEARRAY Ptr
If mdim=3 Then
P=getSafeArray_Ex1 (VT_R8,LBound(A,1),UBound(A,1), LBound(A,2),UBound(A,2),LBound(A,3),UBound(A,3) )
ElseIf mdim=2 Then
P=getSafeArray_Ex(VT_R8,LBound(A,1),UBound(A,1),LBound(A,2),UBound(A,2))
ElseIf mdim=1 Then
P=getSafeArray(VT_R8,LBound(A,1),UBound(A,1))
EndIf
If SafeArrayGetDim(P)=1 Then
VectorToSafeArray(P,A())
ElseIf SafeArrayGetDim(P)=2 Then
For i=LBound(A,1) To UBound(A,1)
bi(0)=i
For j=LBound(A,2) To UBound(A,2)
bi(1)=j
SafeArrayPutElement(P,@bi(0),@A(i,j))
Next
Next
ElseIf SafeArrayGetDim(P)=3 Then
ArrayToSafeArray_Ex(P,A())
End If
Return P
End Function
Sub ArrayToSafeArray (ByRef P As SAFEARRAY Ptr,A() As String)
Dim B() As BSTR
ArrayToSafeArray (P,B())
End Sub
Sub VectorToSafeArray OverLoad ( P As SAFEARRAY Ptr,A() As BSTR)
Dim As Integer i,j,k,mdim =arrayDimCount(A())
Dim bi As Integer
If SafeArrayIsCreated(P)=1 Then
Else
P=getSafeArray(VT_BSTR,LBound(A,1),UBound(A,1))
EndIf
Dim As BSTR Ptr dwArray = NULL
SafeArrayAccessData(P, Cast(Any Ptr,@dwArray))
For i = LBound(A,1) To UBound(A,1)
dwArray[i] = A(i)
Next
SafeArrayUnaccessData(P)
End Sub
Sub VectorToSafeArray OverLoad ( P As SAFEARRAY Ptr,A() As Long)
Dim As Integer i,j, mdim =arrayDimCount(A())
Dim bi As Integer
If SafeArrayIsCreated(P)=1 Then
Else
' P=getSafeArray(VT_BSTR ,LBound(A,1),UBound(A,1))
' If mdim=3 Then
' P=getSafeArray_Ex1 (VT_I4,LBound(A,1),UBound(A,1), LBound(A,2),UBound(A,2),LBound(A,3),UBound(A,3) )
'ElseIf mdim=2 Then
' P=getSafeArray_Ex(VT_I4,LBound(A,1),UBound(A,1),LBound(A,2),UBound(A,2))
If mdim=1 Then
P=getSafeArray(VT_I4,LBound(A,1),UBound(A,1))
EndIf
EndIf
Dim As LONG Ptr dwArray = NULL
SafeArrayAccessData(P, Cast(Any Ptr,@dwArray))
for nCount As Integer = LBound(A,1) To UBound(A,1)
dwArray[nCount] = A(nCount)
Next
SafeArrayUnaccessData(P)
End Sub
Sub VectorToSafeArray OverLoad (ByRef b As SAFEARRAY Ptr,A() As Double)
Dim As Integer i,j
Dim R As Double
Dim bi As Integer
If SafeArrayIsCreated(b)=1 Then
Else
b=getSafeArray(VT_R8,LBound(A),UBound(A))
EndIf
For i=LBound(A,1) To UBound(A,1)
bi=i
SafeArrayPutElement(b,@bi,@A(i))
Next
End Sub
Sub VectorToSafeArray OverLoad (ByRef b As SAFEARRAY Ptr,A() As Single)
Dim As Integer i,j
Dim R As Single
Dim bi As Integer
If SafeArrayIsCreated(b)=1 Then
Else
b=getSafeArray(VT_R4,LBound(A),UBound(A))
EndIf
For i=LBound(A,1) To UBound(A,1)
bi=i
SafeArrayPutElement(b,@bi,@A(i))
Next
End Sub
Sub VectorToSafeArray (ByRef b As SAFEARRAY Ptr,A() As String)
Dim As SAFEARRAYBOUND aDim(1)
aDim(0).lLbound = LBound(A)
aDim(0).cElements = UBound(A)
If b<>NULL Then SafeArrayDestroy(b)
b = SafeArrayCreate(VT_BSTR, 1, @aDim(0))
Dim As BSTR PTR dwArray = NULL
SafeArrayAccessData(b, Cast(Any Ptr,@dwArray))
for nCount As Integer = LBound(A) To UBound(A)
dwArray[nCount] = strToBstr(A(nCount))
Next
SafeArrayUnaccessData(b)
Exit sub
fin:
MessageBox(NULL,"Erreur","string",MB_OK)
End Sub
Sub VectorToSafeArray OverLoad ( P As SAFEARRAY Ptr,A() As Short)
Dim As Integer i,j,k,mdim =arrayDimCount(A())
Dim bi As Integer
If SafeArrayIsCreated(P)=1 Then
Else
P=getSafeArray(VT_I2,LBound(A,1),UBound(A,1))
EndIf
Dim As Short Ptr dwArray = NULL
SafeArrayAccessData(P, Cast(Any Ptr,@dwArray))
For i = LBound(A,1) To UBound(A,1)
dwArray[i] = A(i)
Next
SafeArrayUnaccessData(P)
End Sub
Sub VectorToSafeArray OverLoad ( P As SAFEARRAY Ptr,A() As Any Ptr)
Dim As Integer i,j,k,mdim =arrayDimCount(A())
Dim bi As Integer
If SafeArrayIsCreated(P)=1 Then
Else
P=getSafeArray(VT_VARIANT,LBound(A,1),UBound(A,1))
EndIf
Dim As Any Ptr Ptr dwArray = NULL
SafeArrayAccessData(P, Cast(Any Ptr,@dwArray))
For i = LBound(A,1) To UBound(A,1)
dwArray[i] = A(i)
Next
SafeArrayUnaccessData(P)
End Sub
Sub SafeArrayToArray OverLoad ( A()As Double,P As SAFEARRAY Ptr)
Dim As Integer n1, n2, m1, m2
Dim As Integer i,J
Dim bi(0 To 1) As Integer
If SafeArrayGetDim(P)=1 Then
SafeArrayTovector(A(),P)
ElseIf SafeArrayGetDim(P)=2 Then
SafeArrayGetLBound(P,1,@n1)
SafeArrayGetLBound(P,2,@n2)
SafeArrayGetUBound(P,1,@m1)
SafeArrayGetUBound(P,2,@m2)
ReDim A(n1 To m1, n2 To m2) As Double
For i=n1 To m1
bi(0)=i
For j=n2 To m2
bi(1)=j
SafeArrayGetElement(P,@bi(0),@A(i,j))
Next
Next
ElseIf SafeArrayGetDim(P)=3 Then
SafeArrayToArray_Ex (A(),P)
End If
End Sub
Sub SafeArrayToArray ( A()As Single,P As SAFEARRAY Ptr)
Dim As Integer n1, n2, m1, m2
Dim As Integer i,J
Dim bi(0 To 1) As Integer
If SafeArrayGetDim(P)=1 Then
SafeArrayTovector(A(),P)
ElseIf SafeArrayGetDim(P)=2 Then
SafeArrayGetLBound(P,1,@n1)
SafeArrayGetLBound(P,2,@n2)
SafeArrayGetUBound(P,1,@m1)
SafeArrayGetUBound(P,2,@m2)
ReDim A(n1 To m1, n2 To m2) As Double
For i=n1 To m1
bi(0)=i
For j=n2 To m2
bi(1)=j
SafeArrayGetElement(P,@bi(0),@A(i,j))
Next
Next
ElseIf SafeArrayGetDim(P)=3 Then
' SafeArrayToArray_Ex (A(),P)
End If
End Sub
Sub SafeArrayTovector OverLoad ( A()As Double,ByRef P As SAFEARRAY Ptr)
Dim As Integer n1, n2, m1, m2
Dim As Integer i,J
Dim bi As Integer
SafeArrayGetLBound(P,1,@n1)
SafeArrayGetUBound(P,1,@m1)
ReDim A(n1 To m1) As Double
If SafeArrayGetDim (P) <>1 Then Exit Sub
For i=n1 To m1
bi=i
SafeArrayGetElement(P,@bi,@A(i))
Next
End Sub
Sub SafeArrayTovector( mstr()As BSTR ,P As SAFEARRAY Ptr)
Dim As Integer n1, m1
Dim As Integer i
Dim bi As Integer
SafeArrayGetLBound(P,1,@n1)
SafeArrayGetUBound(P,1,@m1)
ReDim mstr(n1 To m1) As BSTR
Dim As BSTR Ptr arrayAccess = NULL
SafeArrayAccessData(P, Cast(Any Ptr,@arrayAccess))
for iIndex As Integer = n1 To m1
mstr(iIndex)=arrayAccess[iIndex]
Next
SafeArrayUnaccessData(P)
End Sub
Sub SafeArrayTovector ( A()As Single,ByRef P As SAFEARRAY Ptr)
Dim As Integer n1, n2, m1, m2
Dim As Integer i,J
Dim bi As Integer
SafeArrayGetLBound(P,1,@n1)
SafeArrayGetUBound(P,1,@m1)
ReDim A(n1 To m1) As Single
If SafeArrayGetDim (P) <>1 Then Exit Sub
For i=n1 To m1
bi=i
SafeArrayGetElement(P,@bi,@A(i))
Next
End Sub
Sub SafeArrayToArray_Ex ( A()As Double,ByRef P As SAFEARRAY Ptr)
Dim As Integer n1, n2, m1, m2,n3,m3
Dim As Integer i,J,k
Dim bi(0 To 2) As Integer
SafeArrayGetLBound(P,1,@n1)
SafeArrayGetLBound(P,2,@n2)
SafeArrayGetLBound(P,2,@n3)
SafeArrayGetUBound(P,1,@m1)
SafeArrayGetUBound(P,2,@m2)
SafeArrayGetUBound(P,2,@m3)
ReDim A(n1 To m1, n2 To m2, n3 To m3) As Double
For i=n1 To m1
bi(0)=i
For j=n2 To m2
bi(1)=j
For k=n3 To m3
bi(2)=k
SafeArrayGetElement(P,@bi(0),@A(i,j,k))
Next
Next
Next
End Sub
Sub ArrayToVariant OverLoad (ByRef hauteur As VARIANT Ptr ,M() As Double)
Dim As Integer i,j
Dim rgsabound(0 To 1)As SAFEARRAYBOUND
Dim position(0 To 1) As Integer
for i=0 To 1
rgsabound(i).lLbound = LBound(M,i+1)
rgsabound(i).cElements = UBound(M,i+1)-LBound(M,i+1) +1
Next i
VariantInit(hauteur)
hauteur->vt = VT_ARRAY Or VT_R8
hauteur->parray = SafeArrayCreate(VT_R8,2,@rgsabound(0))
for i=LBound(M,1) To UBound(M,1)
position(0) = i
for j=LBound(M,2) To UBound(M,2)
position(1) = j
SafeArrayPutElement(hauteur->parray,@position(0),@M(i,j))
Next j
Next i
End Sub
Function ArrayToVariant(A() As Double)As VARIANT
Dim V As VARIANT
variantinit(@V)
V.vt=VT_ARRAY Or VT_R8
ArrayToSafeArray(V.parray,A())
Return V
End Function
Function ArrayToVariant(A() As Single)As VARIANT
Dim V As VARIANT
variantinit(@V)
V.vt=VT_ARRAY Or VT_R4
ArrayToSafeArray(V.parray,A())
Return V
End Function
Function ArrayToVariant(A() As BSTR)As VARIANT
Dim V As VARIANT
variantinit(@V)
V.vt=VT_ARRAY Or VT_BSTR
ArrayToSafeArray(V.parray,A())
Return V
End Function
Function ArrayToVariant(A() As Long)As VARIANT
Dim V As VARIANT
variantinit(@V)
V.vt=VT_ARRAY Or VT_I4
ArrayToSafeArray(V.parray,A())
Return V
End Function
Function ArrayToVariant(A() As Short)As VARIANT
Dim Vvar As VARIANT
Dim V As VARIANT
variantinit(@V)
V.vt=VT_ARRAY Or VT_I2
ArrayToSafeArray(V.parray,A())
VariantCopy(@Vvar, @V)
VariantClear(@V)
Return Vvar
End Function
'Function ArrayToVariant(A() As BOOL)As VARIANT
'
' Dim V As VARIANT
' variantinit(@V)
' V.vt=VT_ARRAY Or VT_BOOL
' ArrayToSafeArray(V.parray,A())
'
' Return V
'End Function
Function ArrayToVariant(A() As Any Ptr)As VARIANT
Dim V As VARIANT
variantinit(@V)
V.vt=VT_ARRAY Or VT_VARIANT
ArrayToSafeArray(V.parray,A())
Return V
End Function
Function ArrayToVariant(arrySrc() As String)As VARIANT
Dim V As VARIANT
variantinit(@V)
V.vt=VT_ARRAY Or VT_BSTR
ArrayToSafeArray(V.parray,arrySrc())
Return V
End Function
Sub ArrayToVariant (pVariant As VARIANT Ptr , arrySrc() As BSTR)
ASSERT(NULL<>pVariant)
VariantInit(pVariant)
Dim As Integer iMax = UBound(arrySrc)
Dim As SAFEARRAY Ptr pSafeArray
Dim As SAFEARRAYBOUND aDim(1)
aDim(0).lLbound = LBound(arrySrc)
aDim(0).cElements = UBound(arrySrc)
pVariant->vt = VT_ARRAY Or VT_BSTR
pSafeArray = SafeArrayCreate(VT_BSTR, 1, @aDim(0))
Dim As BSTR PTR dwArray = NULL
SafeArrayAccessData(pSafeArray, Cast(Any Ptr,@dwArray))
for nCount As Integer = LBound(arrySrc) To iMax*1
dwArray[nCount] = arrySrc(nCount)
Next
SafeArrayUnaccessData(pSafeArray)
pVariant->parray = pSafeArray
End Sub
Sub ArrayToVariant (pVariant As VARIANT Ptr , arrySrc As BSTR Ptr, n As Integer)
ASSERT(NULL<>pVariant)
VariantInit(pVariant)
Dim As Integer iMax = n
Dim As SAFEARRAY Ptr pSafeArray
Dim As SAFEARRAYBOUND aDim(1)
aDim(0).lLbound = 0
aDim(0).cElements = iMax
pVariant->vt = VT_ARRAY Or VT_BSTR
pSafeArray = SafeArrayCreate(VT_BSTR, 1, @aDim(0))
Dim As BSTR PTR dwArray = NULL
SafeArrayAccessData(pSafeArray, Cast(Any Ptr,@dwArray))
for nCount As Integer = 0 To iMax*1
dwArray[nCount] = arrySrc[nCount]
Next
SafeArrayUnaccessData(pSafeArray)
pVariant->parray = pSafeArray
End Sub
Sub ArrayToVariant (pVariant As VARIANT Ptr , arrySrc() As Any Ptr)
ASSERT(NULL<>pVariant)
VariantInit(pVariant)
Dim As Integer iMax = UBound(arrySrc)
Dim As SAFEARRAY Ptr pSafeArray
Dim As SAFEARRAYBOUND aDim(1)
aDim(0).lLbound = LBound(arrySrc)
aDim(0).cElements = UBound(arrySrc)
pVariant->vt = VT_ARRAY Or VT_VARIANT
pSafeArray = SafeArrayCreate(VT_BSTR, 1, @aDim(0))
Dim As Any Ptr PTR dwArray = NULL
SafeArrayAccessData(pSafeArray, Cast(Any Ptr,@dwArray))
for nCount As Integer = LBound(arrySrc) To iMax*1
dwArray[nCount] = arrySrc(nCount)
Next
SafeArrayUnaccessData(pSafeArray)
pVariant->parray = pSafeArray
End Sub
Sub ArrayToVariantd(ByRef V As VARIANT ,A() As double)
Dim P As SAFEARRAY Ptr
ArrayToSafeArray(P,A() )
V=SafeArrayToVariant(P)
SafeArrayDestroy(P)
End Sub
Sub VariantToArray OverLoad(M() As Double, V As VARIANT)
Dim P As SAFEARRAY Ptr
SafeArrayCopy(V.parray,@P)
SafeArrayToArray( M(),P)
SafeArrayDestroy(P)
End Sub
Sub VariantToArray(M() As Single, V As VARIANT)
Dim P As SAFEARRAY Ptr
SafeArrayCopy(V.parray,@P)
SafeArrayToArray( M(),P)
End Sub
Sub VariantToArray OverLoad(arrySrc() As BSTR,v As VARIANT )
Dim As long lStartBound = 0
Dim As long lEndBound = 0
Dim As SAFEARRAY Ptr pSafeArray = v.parray
ASSERT(NULL<>pSafeArray)
SafeArrayGetLBound(pSafeArray, 1, @lStartBound)
SafeArrayGetUBound(pSafeArray, 1, @lEndBound)
ReDim arrySrc(lStartBound To lEndBound )
Dim As BSTR Ptr arrayAccess = NULL
SafeArrayAccessData(pSafeArray, Cast(Any Ptr,@arrayAccess))
for iIndex As Integer = lStartBound To lEndBound
arrySrc(iIndex)=arrayAccess[iIndex]
Next
SafeArrayDestroy(pSafeArray)
SafeArrayUnaccessData(pSafeArray)
End Sub
Sub VariantToArray(arrySrc() As String,v As VARIANT )
Dim B() As BSTR ' must be dynamic
VariantToArray(B(),v)
ReDim arrySrc(LBound(B) To UBound(B)) As String
For i As Integer=LBound(B) To UBound(B)
arrySrc(i)= BstrToString(B(i))
Next
End Sub
Sub VariantPutElement(value As Any Ptr,i As Integer,j As Integer=0)
'todo
End Sub
Sub VariantToArray OverLoad(arrySrc() As Any Ptr,v As VARIANT )
Dim As long lStartBound = 0
Dim As long lEndBound = 0
Dim As SAFEARRAY Ptr pSafeArray = v.parray
ASSERT(NULL<>pSafeArray)
SafeArrayGetLBound(pSafeArray, 1, @lStartBound)
SafeArrayGetUBound(pSafeArray, 1, @lEndBound)
ReDim arrySrc(lStartBound To lEndBound )
Dim As Any Ptr Ptr arrayAccess = NULL
SafeArrayAccessData(pSafeArray, Cast(Any Ptr,@arrayAccess))
for iIndex As Integer = lStartBound To lEndBound
arrySrc(iIndex)=arrayAccess[iIndex]
Next
SafeArrayDestroy(pSafeArray)
SafeArrayUnaccessData(pSafeArray)
End Sub
Sub SafeArrayTovector( mstr()As String ,P As SAFEARRAY Ptr)
' must be dynamic
Dim As Integer n1, m1
SafeArrayGetLBound(P,1,@n1)
SafeArrayGetUBound(P,1,@m1)
ReDim mstr(n1 To m1)
ReDim B(n1 To m1) As BSTR
Dim As BSTR Ptr arrayAccess = NULL
SafeArrayAccessData(P, Cast(Any Ptr,@arrayAccess))
for i As Integer = n1 To m1
mstr(i)=BstrToString(arrayAccess[i])
Next i
SafeArrayUnaccessData(P)
End Sub
Sub VariantToSafeArray OverLoad (ByVal V As VARIANT ,ByRef P As SAFEARRAY ptr)
If SafeArrayCopy(V.parray,@P)=S_OK Then
Else
Messagebox(getactiveWindow(),"Une erreur est survenue","Convertion variant à SafeArray ",MB_ICONERROR)
P=NULL
End If
End Sub
Function VariantToSafeArray(ByVal V As VARIANT Ptr)As SAFEARRAY Ptr
Dim P As SAFEARRAY Ptr
If SafeArrayCopy(V->parray,@P)=S_OK Then
Return P
Else
Messagebox(getactiveWindow(),"Une erreur est survenue","Convertion variant à SafeArray ",MB_ICONERROR)
Return NULL
End If
End Function
Function SafeArrayToVariant(ByVal P As SAFEARRAY Ptr)As VARIANT
Dim V As VARIANT
If SafeArrayCopy(P,@(V.parray))=S_OK Then
V.vt=P->cbElements
Return V
Else
Messagebox(getactiveWindow(),"Une erreur est survenue","Convertion SafeArray à Variant",MB_ICONERROR)
'Return 0
End If
End Function
function VarArrayCreate(Bounds()As Integer,AVarType As VARTYPE)As VARIANT
Dim V As VARIANT
Dim as Integer I, LDimCount
Dim P As SAFEARRAY Ptr
Dim LVarBounds(0 To 63)As SAFEARRAYBOUND
LDimCount = (UBound(Bounds) + 1) \ 2
for I = 0 to LDimCount - 1
with LVarBounds(I)
.lLbound = Bounds(I * 2)
.cElements = Bounds(I * 2 + 1) - .lLbound + 1
end With
Next
P = SafeArrayCreate(AVarType, LDimCount, @LVarBounds(0))
VariantClear(@V)
V.VT = VT_ARRAY Or AVarType
V.pArray = P
Return V
end function
'function VarArrayDimCount(A As Any Ptr)As Integer
' dim P As SafeArray Ptr
' P=VariantToSafeArray(@A)
' Return P->cDims
'End Function
function VarArrayDimCount(A As Variant)As Integer
dim P As SafeArray Ptr
P=VariantToSafeArray(@A)
Return P->cDims
End Function
Sub VarArrayRedim(ByRef A As Variant, HighBound As Integer)
Dim VarBound As SAFEARRAYBOUND
dim P As SafeArray Ptr
SafearrayCopy(P,@A.parray)
Dim As Integer DimCount =VarArrayDimCount(A)
with *P
VarBound.lLbound = .rgsabound(DimCount - 1).lLbound
VarBound.cElements = HighBound - VarBound.lLbound + 1
End With
SafeArrayRedim(P, @VarBound)
SafearrayCopy(A.parray,@P)
End Sub
Function VarArrayLowBound( A as Variant, iDim as Integer)As Integer
Dim Res As Integer
SafeArrayGetLBound(VariantToSafeArray(@A), iDim, @Res)
Return Res
End Function
function VarArrayHighBound(A As Variant, iDim As Integer)as Integer
Dim Res As Integer
SafeArrayGetUBound(VariantToSafeArray(@A), iDim, @Res)
Return Res
End Function
function VarArrayLock(A As Variant) As Any Ptr
Dim P As Any Ptr
SafeArrayAccessData(VariantToSafeArray(@A), @P)
Return P
End Function
Sub VarArrayUnlock(A as Variant)
SafeArrayUnaccessData(VariantToSafeArray(@A))
end Sub
function VarIsArray( A As Variant)As Boolean
Return (A.VT and vt_Array) = vt_Array
end Function
SUB PrintMatrix OverLoad (ByVal Title AS STRING, A() AS DOUBLE)
DIM AS INTEGER I, J,K
PRINT : PRINT Title : PRINT
FOR I = 1 TO UBOUND(A, 1)
FOR J = 1 TO UBOUND(A, 2)
PRINT USING "#####.##"; A(I, J);
NEXT J
PRINT
NEXT I
END SUB
SUB PrintMatrix (ByVal Title AS STRING, A() AS Double, col1 As Integer,col2 As Integer)
DIM AS INTEGER I, J,K
PRINT : PRINT Title : PRINT
FOR I = LBound(A, 1) TO col1
For J = LBound(A, 2) TO col2
PRINT USING "#####.##"; A(I, J);
NEXT J
PRINT
NEXT I
END Sub
SUB PrintVector(ByVal Title AS STRING, B() AS DOUBLE)
DIM AS INTEGER I
PRINT : PRINT Title : PRINT
FOR I = LBound(B,1) TO UBOUND(B,1)
PRINT USING "#####.##"; B(I)
NEXT I
END SUB
Function RoundFloat( Byval d As Double, Byval p As Integer ) As Double
Dim As Integer t = 10 ^ p
Function = Cint(d * t) / t
End Function
Function FloatToStr(Byval d As Double,byval precision As Integer=2) As String
Dim As String f=""
While d>0
d\=10
f+="#"
Wend
If f="" Then f="#"
f = f & "." & String(precision,"#")
Return f
End Function
