COMatePLUS version 1.2

srod · Post by **srod** » Fri Jun 05, 2009 8:48 pm

Xombie wrote:srod - thanks for the code. I had to fiddle with it a bit to figure out how to work with strings rather than longs but it worked out great in the end.

Cheers!

Xombie, it occurs to me that passing your safearray by reference will be a lot quicker than passing it by value as with my example above. When we pass a variant parameter to COMatePLUS, COMatePLUS performs a deep copy on that variant which in turn will make a deep copy of the underlying array etc. A potentially very slow affair.

We have two alternatives. Either pass the variant by reference or package the safearray up by reference in the variant. Unfortunately, the first alternative will result in COMatePLUS freeing the safearray automatically, potentially before we are done with it (unless we are using a prepared statement).

We should really use the second alternative then and in my tests this makes quite a difference in speed!

The following version of my above 2-d safearray demo passes the array by reference. This will prevent COMatePLUS performing a 'deep copy' of the array and will also prevent COMatePLUS from automatically freeing this array. It is potentially a lot faster than my code above.

Code: Select all

IncludePath ".."
XIncludeFile "COMatePLUS.pbi"


;-Safe array structures - taken from "VariantHelper_Include.pb"
;==============================================================
  Structure SAFEARRAYBOUND 
    cElements.l 
    lLbound.l 
  EndStructure 

  Structure SAFEARRAY 
    cDims.w 
    fFeatures.w 
    cbElements.l 
    cLocks.l 
    *pvData.pData 
    rgsabound.SAFEARRAYBOUND[0] 
  EndStructure 


;-Set up a 2-d safearray of signed integers of dimensions 20 by 20.
;==================================================================
  ;Begin with an array of SAFEARRAYBOUND structures; one for each dimension.
    Dim safeArrayBound.SAFEARRAYBOUND(2)
      With safeArrayBound(0)
        \lLbound = 1
        \cElements = 20
      EndWith
      With safeArrayBound(1)
        \lLbound = 1
        \cElements = 20
      EndWith
  ;Now create the array and check for success.
    *safeArray.SAFEARRAY = SafeArrayCreate_(#VT_I4, 2, @safeArrayBound())
    If *safeArray = 0
      MessageRequester("COMate -Excel 2-d Safearray demo!", "Couldn't create the Safearray!")
      End
    EndIf
  ;Populate the array.
    Dim indices(1)
    For i = 1 To 20
      For j = 1 To 20
        indices(0) = i
        indices(1) = j
        temp = 20*(i-1)+j
        SafeArrayPutElement_(*safeArray, @indices(), @temp)
      Next
    Next
  ;Bundle the Safearray up (by reference) into a variant suitable for passing to a COM method.
    Define var.VARIANT, ptr
    ptr = *safearray
    With var
      \vt = #VT_ARRAY|#VT_I4|#VT_BYREF
      \pparray = @ptr
    EndWith


;-Fire up Excel and load cells from the array in one go.
;=======================================================

Define.COMateObject ExcelObject, WorkBook
ExcelObject = COMate_CreateObject("Excel.Application")

If ExcelObject
  If ExcelObject\SetProperty("Visible = #True") = #S_OK
    WorkBook = ExcelObject\GetObjectProperty("Workbooks\Add")
    If WorkBook
        ExcelObject\SetProperty("Range('A1:T20') = " + Str(var) + " as variant")
      ExcelObject\Invoke("Quit()") 
      WorkBook\Release()
    EndIf
  EndIf
  ExcelObject\Release()
Else
  MessageRequester("COMate -Excel 2-d Safearray demo!", "Couldn't create the application object!")
EndIf

;Now free the Safearray. 
  SafeArrayDestroy_(*safearray)

Note the use of SafeArrayDestroy_() to free the array. VariantClear_() will not free a safearray passed by reference.

srod · Post by **srod** » Fri Jun 05, 2009 9:04 pm

Update - 5th June 2009.

Version 1.1.

COMatePLUS version 1.1 seems to have passed the x64 test (though I still keep an open mind on that score!)

Therefore, COMatePLUS 1.1 is for both PB x86 and PB x64.

I have also upgraded the error reporting to take into account the FACILITY_WIN32 HRESULT values. In the case of such errors being reported, and when COMatePLUS does not recognise the error in question, COMatePLUS will query the system for a suitable Win32 error description etc.

See the nxSoftware site for the download.

mback2k · Post by **mback2k** » Sat Jun 06, 2009 10:12 am

srod, sorry for hijacking your topic again: I have gotten this far with the new approach, but it still does not work, "ICustomDestinationList\AddUserTasks(IObjectArray)" fails and just gives me an error code which means "Wrong parameters".

Do you have any idea?

Code: Select all

EnableExplicit

Procedure PtrGUID(GUID$, *GUID.GUID)
  If CLSIDFromString_(GUID$, *GUID) = #S_OK
    ProcedureReturn *GUID
  EndIf
  ProcedureReturn #False
EndProcedure

Procedure.s StrGUID(*GUID.GUID)
  Protected GUID$ = Space(40)
  If StringFromGUID2_(*GUID, GUID$, Len(GUID$))
    ProcedureReturn GUID$
  EndIf
  ProcedureReturn ""
EndProcedure

Macro CLSID(Name, Text)
  Define __CLSID_#Name.CLSID:PtrGUID(Text, @__CLSID_#Name)
EndMacro

Macro IID(Name, Text)
  Define __IID_#Name.IID,Name.Name:PtrGUID(Text, @__IID_#Name)
EndMacro

Macro GUID(Name, Text)
  Define __GUID_#Name.GUID:PtrGUID(Text, @__GUID_#Name.GUID)
EndMacro

Macro IID_PPV_ARGS(Name)
  @__IID_#Name, @Name
EndMacro

Macro CoInitialize()
  CoInitializeEx_(0, 0)
EndMacro

Macro CoUninitialize()
  CoUninitialize_()
EndMacro

Macro CoCreateInstance(Id, Name)
  CoCreateInstance_(@__CLSID_#Id, 0, 1, IID_PPV_ARGS(Name))
EndMacro

Interface IObjectArray Extends IUnknown
  GetCount(*pcObjects)
  GetAt(uiIndex, riid.IID, *ppv)
EndInterface

Interface IObjectCollection Extends IObjectArray
  AddObject(*punk.IUnknown)
  AddFromArray(*poaSource)
  RemoveObjectAt(uiIndex)
  Clear()
EndInterface

Interface ICustomDestinationList Extends IUnknown
  SetAppID(*pszAppID)
  BeginList(*pcMinSlots, riid.IID, *ppv)
  AppendCategory(*pszCategory, *poa)
  AppendKnownCategory(category)
  AddUserTasks(*poa)
  CommitList()
  GetRemovedDestinations(riid.IID, *ppv)
  DeleteList(*pszAppID)
  AbortList()
EndInterface

CLSID(DestinationList,            "{77f10cf0-3db5-4966-b520-b7c54fd35ed6}")
CLSID(EnumerableObjectCollection, "{2d3468c1-36a7-43b6-ac24-d3f02fd9607a}")
CLSID(ShellLinkW,                 "{00021401-0000-0000-c000-000000000046}")

IID(ICustomDestinationList,       "{6332debf-87b5-4670-90c0-5e57b408a49e}")
IID(IObjectArray,                 "{92ca9dcd-5622-4bba-a805-5e9f541bd8c9}")
IID(IObjectCollection,            "{5632b1a4-e38a-400a-928a-d4cd63230295}")
IID(IShellLinkW,                  "{000214f9-0000-0000-c000-000000000046}")

If OpenWindow(0, 100, 200, 195, 260, "PureBasic Window", #PB_Window_SystemMenu | #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget)
  Define Path$ = ProgramFilename()
  Define MaxSlots

  CoInitialize()
  
  If CoCreateInstance(DestinationList, ICustomDestinationList) = #S_OK
    If ICustomDestinationList\SetAppId(@"PureBasic.Test") = #S_OK
      If ICustomDestinationList\BeginList(@MaxSlots, IID_PPV_ARGS(IObjectArray)) = #S_OK
        IObjectArray\Release()
        
        If CoCreateInstance(EnumerableObjectCollection, IObjectCollection) = #S_OK
          If CoCreateInstance(ShellLinkW, IShellLinkW) = #S_OK
            IShellLinkW\SetPath(@Path$)
            IShellLinkW\SetArguments(@"--blub")
            IShellLinkW\SetDescription(@"Blub")
            If IShellLinkW\Resolve(WindowID(0), 0) = #S_OK
              IObjectCollection\AddObject(IShellLinkW)
            EndIf
            IShellLinkW\Release()
          EndIf
  
          If CoCreateInstance(ShellLinkW, IShellLinkW) = #S_OK
            IShellLinkW\SetPath(@Path$)
            IShellLinkW\SetArguments(@"--blah")
            IShellLinkW\SetDescription(@"Blah")
            If IShellLinkW\Resolve(WindowID(0), 0) = #S_OK
              IObjectCollection\AddObject(IShellLinkW)
            EndIf
            IShellLinkW\Release()
          EndIf
  
          If IObjectCollection\QueryInterface(IID_PPV_ARGS(IObjectArray)) = #S_OK
            ICustomDestinationList\AddUserTasks(IObjectArray) ; <------------------- FAILS
            IObjectArray\Release()
          EndIf
          
          IObjectCollection\Release()
          ICustomDestinationList\CommitList()
        EndIf
      EndIf
    EndIf
    ICustomDestinationList\Release()
  EndIf
  
  CoUninitialize()

  Repeat
  Until WaitWindowEvent() = #PB_Event_CloseWindow
  
EndIf

srod · Post by **srod** » Sat Jun 06, 2009 10:54 am

Sorry, I'm not even going to glance through something with the obfuscating element of macros thrown in! Beside's, I do not have Win 7 and so cannot test anyhow.

**EDIT : okay, a quick glimpse later... why have you placed a IObjectArray\Release() before invoking the ICustomDestinationList\AddUserTasks() method ?

mback2k · Post by **mback2k** » Sat Jun 06, 2009 1:25 pm

srod wrote:Sorry, I'm not even going to glance through something with the obfuscating element of macros thrown in! Beside's, I do not have Win 7 and so cannot test anyhow.

Sorry, I used the Macros to make the code look more clear.

srod wrote:**EDIT : okay, a quick glimpse later... why have you placed a IObjectArray\Release() before invoking the ICustomDestinationList\AddUserTasks() method ?

Because a new IObjectArray instance is created just one line before with:
If IObjectCollection\QueryInterface(IID_PPV_ARGS(IObjectArray)) = #S_OK

Thanks anyway, I will continue to try&error

srod · Post by **srod** » Sat Jun 06, 2009 8:53 pm

Because a new IObjectArray instance is created just one line before ...

Ah yes, told you it was a quick glimpse!

Sorry I can't be of any help here as I simply do not have Win 7.

Post by **flaith** » Mon Jul 20, 2009 7:16 pm

Hi, sorry to disturbed you

i really tried to use the SafeArray with only Strings or Strings and Integer, but i failed

If a good soul can help me :roll:

Thanks

srod · Post by **srod** » Tue Jul 21, 2009 8:43 pm

Here's the SafeArray demo modified to use strings. Note that I use an internal COMatePLUS prototype to create the required BSTRs.

Code: Select all

IncludePath "..\"
XIncludeFile "COMatePLUS.pbi"


;-Safe array structures - taken from "VariantHelper_Include.pb"
;==============================================================
  Structure SAFEARRAYBOUND 
    cElements.l 
    lLbound.l 
  EndStructure 

  Structure SAFEARRAY 
    cDims.w 
    fFeatures.w 
    cbElements.l 
    cLocks.l 
    *pvData.pData 
    rgsabound.SAFEARRAYBOUND[0] 
  EndStructure 


;-Set up a 2-d safearray of signed integers of dimensions 20 by 20.
;==================================================================
  ;Begin with an array of SAFEARRAYBOUND structures; one for each dimension.
    Dim safeArrayBound.SAFEARRAYBOUND(1)
      With safeArrayBound(0)
        \lLbound = 1
        \cElements = 20
      EndWith
      With safeArrayBound(1)
        \lLbound = 1
        \cElements = 20
      EndWith
  ;Now create the array and check for success.
    *safeArray.SAFEARRAY = SafeArrayCreate_(#VT_BSTR, 2, @safeArrayBound())
    If *safeArray = 0
      MessageRequester("COMate -Excel 2-d Safearray demo!", "Couldn't create the Safearray!")
      End
    EndIf
  ;Populate the array.
    Dim indices(1)
    For i = 1 To 20
      For j = 1 To 20
        indices(0) = i
        indices(1) = j
        temp = COMate_MakeBSTR("Cell (" + Str(i) + ", " + Str(j) + ")")
        SafeArrayPutElement_(*safeArray, @indices(), temp)
        SysFreeString_(temp)
      Next
    Next
  ;Bundle the Safearray up into a variant suitable for passing to a COM method.
    Define var.VARIANT
    With var
      \vt = #VT_ARRAY|#VT_BSTR
      \parray = *safeArray
    EndWith


;-Fire up Excel and load cells from the array in one go.
;=======================================================

Define.COMateObject ExcelObject, WorkBook
ExcelObject = COMate_CreateObject("Excel.Application")

If ExcelObject
  If ExcelObject\SetProperty("Visible = #True") = #S_OK
    WorkBook = ExcelObject\GetObjectProperty("Workbooks\Add")
    If WorkBook
        ExcelObject\SetProperty("Range('A1:T20') = " + Str(var) + " as variant")
      ExcelObject\Invoke("Quit()") 
      WorkBook\Release()
    EndIf
  EndIf
  ExcelObject\Release()
Else
  MessageRequester("COMate -Excel 2-d Safearray demo!", "Couldn't create the application object!")
EndIf

;Now free the Safearray. Either use SafeArrayDestroy_() or VariantClear_() on any variant containing the array.
  VariantClear_(var)

If you wish to populate the array with a combination of strings and integers then you need to use an array of variants. A little fiddly to set up. You're probably better just using strings and convert the integers to strings as appropriate.

Post by **flaith** » Wed Jul 22, 2009 6:35 pm

srod wrote:Here's the SafeArray demo modified to use strings. Note that I use an internal COMatePLUS prototype to create the required BSTRs.
Code: Select all
...
        temp = COMate_MakeBSTR("Cell (" + Str(i) + ", " + Str(j) + ")")
        SafeArrayPutElement_(*safeArray, @indices(), temp)
        SysFreeString_(temp)
...

i missed that one, thanks a lot srod

srod wrote:If you wish to populate the array with a combination of strings and integers then you need to use an array of variants. A little fiddly to set up. You're probably better just using strings and convert the integers to strings as appropriate.

i'll follow your advice, thanks again

mk-soft · Post by **mk-soft** » Thu Aug 13, 2009 12:03 pm

Update version of VariantHelper_Include.pb

New:
- VariantClear(...): now checked varianttype VT_ARRAY and call SafeArrayDestroy
- Replaced VariantClear_()

MSDN

SafeArrayDestroy
Destroys an existing array descriptor and all of the data in the array. If objects are stored in the array, Release is called on each object in the array.

V2.09

Code: Select all

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

Define.l vhLastError, saLastError


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

Import "oleaut32.lib"
  SafeArrayAllocDescriptorEx(a.l,b.l,c.l) As "_SafeArrayAllocDescriptorEx@12"
  SafeArrayGetVartype(a.l,b.l) As "_SafeArrayGetVartype@8"
EndImport

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

;- Structure SAFEARRAY
Structure SAFEARRAYBOUND
  cElements.l
  lLbound.l
EndStructure

Structure pData
  StructureUnion
    bVal.b[0]; AS BYTE            ' VT_UI1
    iVal.w[0]; AS INTEGER         ' VT_I2
    lVal.l[0]; AS LONG            ' VT_I4
    llVal.q[0]; AS QUAD           ' VT_I8
    fltVal.f[0]; AS SINGLE        ' VT_R4
    dblVal.d[0]; AS DOUBLE        ' VT_R8
    boolVal.w[0]; AS INTEGER      ' VT_BOOL
    scode.l[0]; AS LONG           ' VT_ERROR
    cyVal.l[0]; AS LONG           ' VT_CY
    date.d[0]; AS DOUBLE          ' VT_DATE
    bstrVal.l[0]; AS LONG         ' VT_BSTR
    punkVal.l[0]; AS DWORD        ' VT_UNKNOWN
    pdispVal.l[0]; AS DWORD       ' VT_DISPATCH
    parray.l[0]; AS DWORD         ' VT_ARRAY|*
    Value.Variant[0];
  EndStructureUnion
EndStructure
 
Structure SAFEARRAY
  cDims.w
  fFeatures.w
  cbElements.l
  cLocks.l
  *pvData.pData
  rgsabound.SAFEARRAYBOUND[0]
EndStructure

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

;- 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

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


;- 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#\pvDataiVal[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

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

Post by **Kiffi** » Thu Aug 13, 2009 12:20 pm

mk-soft wrote:Update version of VariantHelper_Include.pb

Thanks!

Greetings ... Kiffi

Peyman · Post by **Peyman** » Sun Aug 30, 2009 3:12 am

Thanks srod really nice work.

how can placing COMatePlus within a dll and use it for other programs ? i think there is a problem in COMate_CreateActiveXControl() for do this job, COMatePLUS.pbi what changes want ?

srod · Post by **srod** » Sun Aug 30, 2009 10:53 am

Lots of changes would be required! Yes, COMate_CreateActiveXControl() should crash if exported from a dll. A parent window for the control will need specifiying to rectify this.

Sorry but COMatePLUS is really not suited for placing in a dll so that its functions can be used from client applications. (There is no problem placing it in a dll and calling the functions from the dll, but exporting those functions is a different matter!)

Whilst I could create a dll from COMatePLUS, it would require too many changes and it is not something I require or see any need for and so I will not be doing this. Sorry.

Peyman · Post by **Peyman** » Sun Aug 30, 2009 8:14 pm

thanks srod for this Powerfull COM.
this is very good if this have a dll version for other programming lang that cant work with com, i create a tinty url from your COMatePLUS and it worked for purebasic apps and other programming

COM Dll :

Code: Select all

IncludePath "..\"
XIncludeFile "COMatePLUS.pbi"

ProcedureDLL COM_CreateObject(progID$, hWnd = 0, blnInitCOM = #True)

  Define.COMateObject Object
  Object = Comate_CreateObject(progID$, hWnd, blnInitCOM)
  
	ProcedureReturn Object
EndProcedure


ProcedureDLL COM_SetProperty(obj, Property$, value$)
	
  Define.COMateObject Object
  
  Object = obj
 
  Object\SetProperty(property$ + " = " + value$)

EndProcedure

ProcedureDLL COM_Invoke(obj, method$, params$)

  Define.COMateObject Object
  Object = obj
  
	ret = Object\Invoke(method$ + "(" + params$ + ")")
	
	ProcedureReturn ret
EndProcedure


ProcedureDLL COM_Release(obj)

	Define.COMateObject Object
  Object = obj
  
	Object\Release()
	
EndProcedure

Test:

Code: Select all

;/////////////////////////////////////////////////////////////////////////////////
;***COMate***  COM automation through iDispatch.
;*===========
;*
;*Acrobat PDF demo - by Stefan Schnell.
;*Edit By  Peyman for COMatePLUS DLl
;/////////////////////////////////////////////////////////////////////////////////

IncludePath "..\"
XIncludeFile "COMatePLUS.pbi"


Define.COMateObject PDFObject

Com_lib = LoadLibrary_("COM.dll")
COM_CreateObject = GetProcAddress_(Com_lib, "COM_CreateObject")
COM_SetProperty = GetProcAddress_(Com_lib, "COM_SetProperty")
COM_Invoke = GetProcAddress_(Com_lib, "COM_Invoke")
COM_Release = GetProcAddress_(Com_lib, "COM_Release")


If OpenWindow(0, 0, 0, 800, 800, "COMate PDF-Demo", #PB_Window_SystemMenu|#PB_Window_SizeGadget|#PB_Window_MaximizeGadget|#PB_Window_MinimizeGadget)

  pdfObject = CallFunctionFast(COM_CreateObject, "AcroPDF.PDF.1", WindowID(0))
  
  Debug PDFObject

  If pdfObject
    CallFunctionFast(COM_SetProperty, pdfObject, "src", "'C:\downloads\www.irpdf.com(3149).pdf'")
    CallFunctionFast(COM_SetProperty, pdfObject, "setShowToolbar", "1")
    CallFunctionFast(COM_SetProperty, pdfObject, "setView", "'Fitv'")
    CallFunctionFast(COM_SetProperty, pdfObject, "setPageMode", "'none'")

    While WaitWindowEvent() <> #PB_Event_CloseWindow : Wend 
    CloseWindow(0)
    ;pdfObject\Release()
    CallFunctionFast(COM_Release, pdfObject)
    FreeLibrary_(Com_lib)
  Else
    MessageRequester("COMate -Acrobat PDF demo", "Couldn't create the ActiveX object!")
  EndIf
EndIf

i realy love this and want change codes to dll for other progarm.
in the COMate_CreateActiveXControl() you use this :

Code: Select all

id = ContainerGadget(#PB_Any, x, y, width, 	height)

and this just suitable for Purebasic, when i change it to window handle control created but control fill all of my window what code we can use to create something like ContainerGadget in all window with its handle ? any idea. :roll:

srod · Post by **srod** » Sun Aug 30, 2009 8:39 pm

Sorry Peyman, but I haven't time to assist with this right now. There are a lot of problems for you to overcome before you can create a dll out of the COMatePLUS library.