PureBasic Forums - English

http://www.purebasic.com
https://www.purebasic.fr/english/

PureDispHelper UserLib - Update with Includefile for Unicode

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

Page 7 of 18

Posted: Thu Apr 26, 2007 9:51 pm
by freak
My code has had a line with a compiler bug in 4.02 inside. Fred is on it, and i changed
the above code to work around it for now, so please anybody that uses it
get it from my above post again.

Sorry for this.

Posted: Thu Apr 26, 2007 11:03 pm
by Kiffi
@freak:

thanks for your fast support! :D


@all:

here is a small example how to add nodes to a MSComctlLib.TreeCtrl and
how to get the text of the selected node by using the excellent
ComEventSink.pb from freak.

Code: Select all

EnableExplicit

Global oTreeView.l

Enumeration
  #NodeText
EndEnumeration

Enumeration ; LabelEdit
  #tvwAutomatic
  #tvwManual
EndEnumeration

Enumeration ; Relationship
  #tvwFirst
  #tvwLast
  #tvwNext
  #tvwPrevious
  #tvwChild
EndEnumeration

XIncludeFile "ComEventSink.pbi"

dhToggleExceptions(#True)

Procedure Event_NodeClick()
  
  Protected oTreeNode.l
  Protected szResponse.l

  ; get the selected node
  dhGetValue("%o", @oTreeNode, oTreeView, ".SelectedItem")
  
  If oTreeNode
    
    ; get the text of the selected node
    dhGetValue("%s", @szResponse, oTreeNode, ".Text")
    
    If szResponse
      SetGadgetText(#NodeText, PeekS(szResponse))
      dhFreeString(szResponse) : szResponse = 0
    EndIf
    
    dhReleaseObject(oTreeNode)
    
  EndIf
  
EndProcedure

Procedure EventCallback(Event$, ParameterCount, *Params)
  
  Select Event$
    Case "NodeClick" : Event_NodeClick()
    Case "MouseMove"
    Default          : Debug Event$
  EndSelect
  
EndProcedure

Procedure.l TreeviewNodesAdd(oTreeView.l, Relative.s = "", Relationship.l = -1, key.s = "", Text.s = "")
  
  Protected obj.l
  dhGetValue("%o", @obj, oTreeView, ".Nodes.Add(%s, %d, %s, %s)", @Relative, Relationship, @key, @Text)
  ProcedureReturn obj
  
EndProcedure

Define.l I
Define oTreeNode.l

If OpenWindow(0, #PB_Ignore, #PB_Ignore, 200, 400, "TreeView") And CreateGadgetList(WindowID(0))
  
  StringGadget(#NodeText, 5, 5, 190, 20,"")
  
  oTreeView = OCX_CreateGadget(1, 5, 30, 190, 365, "MSComctlLib.TreeCtrl")
  
  dhPutValue(oTreeView, ".HideSelection=%b", #False)
  dhPutValue(oTreeView, ".LabelEdit=%d", #tvwManual)
  ; dhPutValue(oTreeView, ".Indentation=%d", 5) ; doesn't work. why?
  
  OCX_ConnectEvents(oTreeView, @EventCallback())
  
  ; ---
  
  ; Add Rootnode
  dhGetValue("%o", @oTreeNode, oTreeView, ".Nodes.Add")
  dhPutValue(oTreeNode, ".Text=%s", @"Root")
  dhPutValue(oTreeNode, ".Key=%s", @"root")
  dhPutValue(oTreeNode, ".Expanded=%b", #True) ; Make sure that every parentnode is expanded (for demo only to see, that there are further subnodes)
  
  ; ---
  
  ; Add First SubNode
  oTreeNode = TreeviewNodesAdd(oTreeView, "root", #tvwChild, "animals", "Animals")
  dhPutValue(oTreeNode, ".Expanded=%b", #True) ; Make sure that every parentnode is expanded (for demo only to see, that there are further subnodes)
  
  ; Add First SubSubNode
  oTreeNode = TreeviewNodesAdd(oTreeView, "animals", #tvwChild, "cats", "Cats")
  ; Add Second SubSubNode
  oTreeNode = TreeviewNodesAdd(oTreeView, "animals", #tvwChild, "dogs", "Dogs")
  
  ; ---
  
  ; Add Second SubNode
  oTreeNode = TreeviewNodesAdd(oTreeView, "root", #tvwChild, "cars", "Cars")
  dhPutValue(oTreeNode, ".Expanded=%b", #True) ; Make sure that every parentnode is expanded (for demo only to see, that there are further subnodes)
  
  ; Add First SubSubNode
  oTreeNode = TreeviewNodesAdd(oTreeView, "cars", #tvwChild, "ferrari", "Ferrari")
  ; Add Second SubSubNode
  oTreeNode = TreeviewNodesAdd(oTreeView, "cars", #tvwChild, "lamborghini", "Lamborghini")
  
  ; ---
  
  ; Now select the first SubSubnode (Cats)
  dhGetValue("%o", @oTreeNode, oTreeView, ".Nodes(%s)", @"cats")
  dhPutValue(oTreeNode, ".Selected=%b", #True)
  Event_NodeClick()
  
  ; ---
  
  Define.l WWE
  Define.s NewNodeText
  
  Repeat
    
    WWE=WaitWindowEvent()
    
    Select WWE
      Case #PB_Event_Gadget
        Select EventGadget()
          Case #NodeText
            If EventType() = #PB_EventType_Change
              
              dhGetValue("%o", @oTreeNode, oTreeView, ".SelectedItem")
              
              If oTreeNode
                NewNodeText=GetGadgetText(#NodeText)
                dhPutValue(oTreeNode, ".Text=%s", @NewNodeText)
                dhReleaseObject(oTreeNode)
              EndIf
              
            EndIf
        EndSelect
    EndSelect
    
  Until WWE = #PB_Event_CloseWindow
  
  CloseWindow(0)
  
  dhReleaseObject(oTreeNode)
  dhReleaseObject(oTreeView)
  
EndIf
Greetings ... Kiffi

Posted: Thu Apr 26, 2007 11:16 pm
by Dare
Now this is awesome.

Thanks Freak.

Thanks to all providing examples and info!

Posted: Thu Apr 26, 2007 11:34 pm
by DoubleDutch
Wow! Just seen this thread. Great work! :)

Posted: Sat Apr 28, 2007 9:51 pm
by LuckyLuke
Question ...

Is this the correct way of using the date structure ?
The result is always december :?

Code: Select all

  date1.dh_Date
  date1\wYear = Year(Date())
  date1\wMonth = Month(Date())
  date1\wDay = Day(Date()) - 2
  
  date2.dh_Date
  date2\wYear = Year(Date())
  date2\wMonth = Month(Date())
  date2\wDay = Day(Date()) + 2
  
  dhCallMethod(oDayView, ".ShowDays(%D, %D)", date1, date2)
Thanks.

Posted: Sat Apr 28, 2007 11:50 pm
by LuckyLuke
Solved the problem ...
I have to use the string parameter for date... strange, but it works :-)

Code: Select all

dhCallMethod(DayView, "ShowDay(%s)", @"31/12/2007")
Thanks for this great lib. It opens a new world for PureBasic users. :D

Posted: Sun Apr 29, 2007 5:22 am
by ts-soft
Update: Version 1.2

Include/Import file with unicode-support and source added.

The include-version is not so easy, but it works. I have in the moment
only the base-functions imported, but you can help to enhance this file.

Posted: Sun Apr 29, 2007 8:23 am
by KIKI
I have a problem with Open Office org automation
It seems that this instruction make a crash

Code: Select all

dhGetValue("%o",@oDoc, oDesk,".loadComponentFromURL(%s,%s,%b,%s)",@"private:factory/swriter", @"_blank", 1 ,openpar )
PB compiler return that's error
Fonction GetValue
Error in Invoke Array
Type Mismatch "LoadcomponentFromurl.argument.index:3
Code 80020005
Source Idispatch.Interface :(

Note Openpar in an array of 3 elements

Posted: Sun Apr 29, 2007 7:58 pm
by ts-soft
KIKI wrote: Type Mismatch "LoadcomponentFromurl.argument.index:3
This parameter isn't a bool, so test it with %d


Info to use the new "DispHelper_Include.pb"
This changes required to use with include in ansi and unicode:

Add this 2 lines at beginning:

Code: Select all

XIncludeFile "DispHelper_Include.pb"
dhInitializeImp()
Change all string-parameter from "%s" to "%T"

Add this line to the end of source:

Code: Select all

dhUninitialize()
It should work on most sources, i hope :wink:

Posted: Sun Apr 29, 2007 10:09 pm
by ts-soft
Small example using Disphelper_Include

Code: Select all

XIncludeFile "DispHelper_Include.pb"; if you use the userlib, comment this out

dhInitializeImp(); if you use the userlib, comment this out

dhToggleExceptions(#True)

Procedure DownLoadWebPage(szURL.s, szFileName.s)
  Protected objHTTP.l, Response.l, Status.l, File.l

  objHTTP = dhCreateObject("MSXML2.XMLHTTP")
  If objHTTP
    dhCallMethod(objHTTP, ".Open(%T, %T, %b)", @"GET", @szURL, #False)
    dhCallMethod(objHTTP, ".Send")

    dhGetValue("%T", @Status, objHTTP, ".StatusText")
    If Status <> 0
      If UCase(PeekS(Status)) = "OK"
        dhFreeString(Status)
        dhGetValue("%T", @Response, objHTTP, ".ResponseText")
        If Response <> 0
          File = CreateFile(#PB_Any, szFileName)
          If File
            WriteString(File, PeekS(Response))
            CloseFile(File)
            dhFreeString(Response)
            ProcedureReturn #True
          EndIf
          dhFreeString(Response)
        EndIf
      EndIf
    EndIf
    dhReleaseObject(objHTTP)
  EndIf
EndProcedure

Define.s FileName = GetTemporaryDirectory() + "test.html"

If DownLoadWebPage("http://ts-soft.eu", FileName)
  RunProgram(FileName)
EndIf

dhUninitialize(); if you use the userlib, comment this out
works with include in Unicode and ANSI mode

Posted: Mon Apr 30, 2007 8:30 pm
by ts-soft
PureDisphelper or Disphelper_Include.pb works fine with objects, longs,
strings as parameter, but not with Double, Quad and so on. To use this
Types, you can define as Variant.

For easy using of VARIANT, i have added the "VariantHelper_Include.pb"
from mk-soft, here the source:

Code: Select all

;-TOP
; Kommentar     : Variant Helper
; Author        : mk-soft
; Second Author :
; Datei         : VariantHelper_Include.pb
; Version       : 2.02
; Erstellt      : 30.04.2007
; Geändert      :
;
; Compilermode  :
;
; ***************************************************************************************


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

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

; ***************************************************************************************
; UNICODE / ASCII Helper for SysAllocString
Procedure helpSysAllocString(*Value)
  ProcedureReturn SysAllocString_(*Value)
EndProcedure
Prototype.l ProtoSysAllocString(Value.p-unicode)
;-T_BSTR
Global T_BSTR.ProtoSysAllocString = @helpSysAllocString()

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

Procedure.d T_DATE(pbDate)
 
  Protected date.d
 
  date = pbDate / 86400.0 + 25569.0
  ProcedureReturn date
 
EndProcedure

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

Define.l vhLastError
Define.s vhLastMessage

Procedure.l vhLastError()

  Shared vhLastError.l
 
  ProcedureReturn vhLastError
 
EndProcedure

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

Procedure.s vhLastMessage()

  Shared vhLastMessage.s

  ProcedureReturn vhLastMessage
 
EndProcedure

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

Procedure.s VT_STR(*Var.Variant)

  Shared vhLastError.l
  Shared vhLastMessage.s

  If *Var
    Select *Var\vt
      Case #VT_BSTR
        ProcedureReturn PeekS(*Var\bstrVal, #PB_Any, #PB_Unicode)
      Case #VT_BOOL
        ProcedureReturn Str(*Var\boolVal)
      Case #VT_I1, #VT_UI1
        ProcedureReturn Str(*Var\bVal)
      Case #VT_I2, #VT_UI2
        ProcedureReturn Str(*Var\iVal)
      Case #VT_I4, #VT_UI4
        ProcedureReturn Str(*Var\lVal)
      Case #VT_I8, #VT_UI8
        ProcedureReturn StrQ(*Var\llVal)
      Case #VT_R4
        ProcedureReturn StrF(*Var\fltVal)
      Case #VT_R8
        ProcedureReturn StrD(*Var\dblVal)
         
      Default
        vhLastError = $80020008
        vhLastMessage = "DISP_E_BADVARTYPE"
        ProcedureReturn ""
     
    EndSelect
  EndIf
EndProcedure
 
; ***************************************************************************************
 
Procedure.l VT_BOOL(*Var.Variant)

  Shared vhLastError.l
  Shared vhLastMessage.s

  Protected result.l

  If *Var
    Select *Var\vt
      Case #VT_BOOL
        result = *Var\boolVal
      Case #VT_I1, #VT_UI1
        result = *Var\bVal
      Case #VT_I2, #VT_UI2
        result = *Var\iVal
      Case #VT_I4, #VT_UI4
        result = *Var\lVal
      Case #VT_I8, #VT_UI8
        result = *Var\llVal
      Case #VT_R4
        result = *Var\fltVal
      Case #VT_R8
         *Var\dblVal
      Default
        vhLastError = $80020008
        vhLastMessage = "DISP_E_BADVARTYPE"
        result = 0
    EndSelect
    If result
      ProcedureReturn #True
    Else
      ProcedureReturn #False
    EndIf
  EndIf
EndProcedure
 
; ***************************************************************************************

Procedure.b VT_BYTE(*Var.Variant)

  Shared vhLastError.l
  Shared vhLastMessage.s

  If *Var
    Select *Var\vt
      Case #VT_BOOL
        ProcedureReturn *Var\boolVal
      Case #VT_I1, #VT_UI1
        ProcedureReturn *Var\bVal
      Case #VT_I2, #VT_UI2
        ProcedureReturn *Var\iVal
      Case #VT_I4, #VT_UI4
        ProcedureReturn *Var\lVal
      Case #VT_I8, #VT_UI8
        ProcedureReturn *Var\llVal
      Case #VT_R4
        ProcedureReturn *Var\fltVal
      Case #VT_R8
        ProcedureReturn *Var\dblVal
      Case #VT_BSTR
        ProcedureReturn Val(PeekS(*Var\bstrVal, #PB_Any, #PB_Unicode))
         
      Default
        vhLastError = $80020008
        vhLastMessage = "DISP_E_BADVARTYPE"
        ProcedureReturn 0
     
    EndSelect
  EndIf
EndProcedure
 
; ***************************************************************************************

Procedure.w VT_WORD(*Var.Variant)

  Shared vhLastError.l
  Shared vhLastMessage.s

  If *Var
    Select *Var\vt
      Case #VT_BOOL
        ProcedureReturn *Var\boolVal
      Case #VT_I1, #VT_UI1
        ProcedureReturn *Var\bVal
      Case #VT_I2, #VT_UI2
        ProcedureReturn *Var\iVal
      Case #VT_I4, #VT_UI4
        ProcedureReturn *Var\lVal
      Case #VT_I8, #VT_UI8
        ProcedureReturn *Var\llVal
      Case #VT_R4
        ProcedureReturn *Var\fltVal
      Case #VT_R8
        ProcedureReturn *Var\dblVal
      Case #VT_BSTR
        ProcedureReturn Val(PeekS(*Var\bstrVal, #PB_Any, #PB_Unicode))
         
      Default
        vhLastError = $80020008
        vhLastMessage = "DISP_E_BADVARTYPE"
        ProcedureReturn 0
     
    EndSelect
  EndIf
EndProcedure
 
; ***************************************************************************************

Procedure.l VT_LONG(*Var.Variant)

  Shared vhLastError.l
  Shared vhLastMessage.s

  If *Var
    Select *Var\vt
      Case #VT_BOOL
        ProcedureReturn *Var\boolVal
      Case #VT_I1, #VT_UI1
        ProcedureReturn *Var\bVal
      Case #VT_I2, #VT_UI2
        ProcedureReturn *Var\iVal
      Case #VT_I4, #VT_UI4
        ProcedureReturn *Var\lVal
      Case #VT_I8, #VT_UI8
        ProcedureReturn *Var\llVal
      Case #VT_R4
        ProcedureReturn *Var\fltVal
      Case #VT_R8
        ProcedureReturn *Var\dblVal
      Case #VT_BSTR
        ProcedureReturn Val(PeekS(*Var\bstrVal, #PB_Any, #PB_Unicode))
         
      Default
        vhLastError = $80020008
        vhLastMessage = "DISP_E_BADVARTYPE"
        ProcedureReturn 0
     
    EndSelect
  EndIf
EndProcedure
 
; ***************************************************************************************

Procedure.q VT_QUAD(*Var.Variant)

  Shared vhLastError.l
  Shared vhLastMessage.s

  If *Var
    Select *Var\vt
      Case #VT_BOOL
        ProcedureReturn *Var\boolVal
      Case #VT_I1, #VT_UI1
        ProcedureReturn *Var\bVal
      Case #VT_I2, #VT_UI2
        ProcedureReturn *Var\iVal
      Case #VT_I4, #VT_UI4
        ProcedureReturn *Var\lVal
      Case #VT_I8, #VT_UI8
        ProcedureReturn *Var\llVal
      Case #VT_R4
        ProcedureReturn *Var\fltVal
      Case #VT_R8
        ProcedureReturn *Var\dblVal
      Case #VT_BSTR
        ProcedureReturn ValQ(PeekS(*Var\bstrVal, #PB_Any, #PB_Unicode))
         
      Default
        vhLastError = $80020008
        vhLastMessage = "DISP_E_BADVARTYPE"
        ProcedureReturn 0
     
    EndSelect
  EndIf
EndProcedure
 
; ***************************************************************************************

Procedure.f VT_FLOAT(*Var.Variant)

  Shared vhLastError.l
  Shared vhLastMessage.s

  If *Var
    Select *Var\vt
      Case #VT_BOOL
        ProcedureReturn *Var\boolVal
      Case #VT_I1, #VT_UI1
        ProcedureReturn *Var\bVal
      Case #VT_I2, #VT_UI2
        ProcedureReturn *Var\iVal
      Case #VT_I4, #VT_UI4
        ProcedureReturn *Var\lVal
      Case #VT_I8, #VT_UI8
        ProcedureReturn *Var\llVal
      Case #VT_R4
        ProcedureReturn *Var\fltVal
      Case #VT_R8
        ProcedureReturn *Var\dblVal
      Case #VT_BSTR
        ProcedureReturn ValF(PeekS(*Var\bstrVal, #PB_Any, #PB_Unicode))
         
      Default
        vhLastError = $80020008
        vhLastMessage = "DISP_E_BADVARTYPE"
        ProcedureReturn 0
     
    EndSelect
  EndIf
EndProcedure
 
; ***************************************************************************************

Procedure.d VT_DOUBLE(*Var.Variant)

  Shared vhLastError.l
  Shared vhLastMessage.s

  If *Var
    Select *Var\vt
      Case #VT_BOOL
        ProcedureReturn *Var\boolVal
      Case #VT_I1, #VT_UI1
        ProcedureReturn *Var\bVal
      Case #VT_I2, #VT_UI2
        ProcedureReturn *Var\iVal
      Case #VT_I4, #VT_UI4
        ProcedureReturn *Var\lVal
      Case #VT_I8, #VT_UI8
        ProcedureReturn *Var\llVal
      Case #VT_R4
        ProcedureReturn *Var\fltVal
      Case #VT_R8
        ProcedureReturn *Var\dblVal
      Case #VT_BSTR
        ProcedureReturn ValD(PeekS(*Var\bstrVal, #PB_Any, #PB_Unicode))
         
      Default
        vhLastError = $80020008
        vhLastMessage = "DISP_E_BADVARTYPE"
        ProcedureReturn 0
     
    EndSelect
  EndIf
EndProcedure
 
; ***************************************************************************************

Procedure.l VT_DATE(*Var.Variant) ; PB-Datum

  Shared vhLastError.l
  Shared vhLastMessage.s

  Protected pbDate
 
  If *Var
    Select *Var\vt
      Case #VT_DATE
        pbDate = (*Var\dblVal  - 25569.0) * 86400.0
        ProcedureReturn pbDate
      Default
        vhLastError = $80020008
        vhLastMessage = "DISP_E_BADVARTYPE"
        ProcedureReturn 0
     
    EndSelect
  EndIf
EndProcedure
 
; ***************************************************************************************

Procedure.l GetVariantSafeArrayCount(*Var.Variant)
  Protected result.l, *array.safearray
  If *Var
    If (*Var\vt & #VT_ARRAY) = #VT_ARRAY
      *array = *Var\parray
      result = *array\rgsabound\cElements
    Else
      result = 0
    EndIf
  Else
    result = 0
  EndIf
  ProcedureReturn result
EndProcedure

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

Procedure.l GetVariantSafeArrayVarType(*Var.Variant)
  Protected result.l, *array.safearray
  If *Var
    result = *Var\vt & $1FFF
  Else
    result = 0
  EndIf
  ProcedureReturn result
EndProcedure

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

Procedure.l GetVariantSafeArray(*Var.Variant)
  Protected result.l, *array.safearray
  If *Var
    If (*Var\vt & #VT_ARRAY) = #VT_ARRAY
      *array = *Var\parray
      result = *array\pvdata
    Else
      result = 0
    EndIf
  Else
    result = 0
  EndIf
  ProcedureReturn result
EndProcedure

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

Macro V_EMPTY(Arg)
  VariantClear_(Arg)
  Arg\vt = #VT_EMPTY
  arg\llVal = 0
EndMacro

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

Macro V_NULL(Arg)
  VariantClear_(Arg)
  Arg\vt = #VT_NULL
  arg\bstrVal
EndMacro

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

Macro V_DISP(Arg)
  VariantClear_(Arg)
  Arg\vt = #VT_DISPATCH
  arg\pdispVal
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

; ***************************************************************************************
Example:

Code: Select all

; example by Kiffi
; enhanced by mk-soft

EnableExplicit

XIncludeFile "DispHelper_Include.pb"
XIncludeFile "VariantHelper_Include.pb"

Define.l ExcelApp, Workbook

dhInitializeImp()
dhToggleExceptions(#True)

ExcelApp = dhCreateObject("Excel.Application")

Define.variant wert1, wert2, wert3, result, text

V_DOUBLE(wert1) = 3.33333333333333
V_DOUBLE(wert2) = 4.44444444444444
V_DOUBLE(wert3) = 5.55555555555555
V_STR(text) = T_BSTR("Hallo Welt")

If ExcelApp
 
  dhPutValue(ExcelApp, ".Visible = %b", #True)
 
  dhGetValue("%o", @Workbook, ExcelApp, ".Workbooks.Add")
 
  dhPutValue(ExcelApp, "Cells(%d, %d).Value = %T", 1, 1, @"Feel")
  dhPutValue(ExcelApp, "Cells(%d, %d).Value = %T", 2, 1, @"the")
  dhPutValue(ExcelApp, "Cells(%d, %d).Value = %T", 3, 1, @"pure")
  dhPutValue(ExcelApp, "Cells(%d, %d).Value = %T", 4, 1, @"Power")
 
  dhPutValue(ExcelApp, "Cells(%d, %d).Value = %T", 1, 2, @"the")
  dhPutValue(ExcelApp, "Cells(%d, %d).Value = %T", 1, 3, @"pure")
  dhPutValue(ExcelApp, "Cells(%d, %d).Value = %T", 1, 4, @"Power")

  dhPutValue(ExcelApp, "Cells(%d, %d).Value = %v", 2, 2, wert1)
  dhPutValue(ExcelApp, "Cells(%d, %d).Value = %v", 2, 3, wert2)
  dhPutValue(ExcelApp, "Cells(%d, %d).Value = %v", 2, 4, wert3)

  dhPutValue(ExcelApp, "Cells(%d, %d).Value = %v", 3, 2, text)

  dhGetValue("%v", @result, ExcelApp, "Cells(%d, %d).Value", 2, 2)

  MessageRequester("PureDispHelper-ExcelDemo", "Result Cells(2,2): " + VT_STR(result))

  MessageRequester("PureDispHelper-ExcelDemo", "Click OK to close Excel")
 
  dhCallMethod(ExcelApp, ".Quit")
 
  dhReleaseObject(Workbook) : Workbook = 0
  dhReleaseObject(ExcelApp) : ExcelApp = 0
 
Else
 
  MessageRequester("PureDispHelper-ExcelDemo", "Couldn't create Excel-Object")
  
EndIf

dhUninitialize()

Posted: Mon Apr 30, 2007 9:16 pm
by freak
You should use the VariantChangeType_() API to convert a VARIANT to a target type. It is better than handling any possible type of VARIANT individually.
This will make all the VT_STR() like procedures much shorter and it can handle many types of conversions.
You can look at my ComEventSink code, i use it there in the functions to retrieve the parameters.

Posted: Mon Apr 30, 2007 9:36 pm
by mk-soft
Ok,

Is in work

Thanks

FF :wink:

Posted: Mon Apr 30, 2007 9:51 pm
by ts-soft
thanks to all helpers :D

Posted: Mon Apr 30, 2007 10:10 pm
by mk-soft
Now Update for VariantHelper

Code: Select all

;-TOP
; Kommentar     : Variant Helper
; Author        : mk-soft
; Second Author : 
; Datei         : VariantHelper_Include.pb
; Version       : 2.03
; Erstellt      : 30.04.2007
; Geändert      :
; 
; Compilermode  :
;
; ***************************************************************************************

Define.l vhLastError

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

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

; ***************************************************************************************
; UNICODE / ASCII Helper for SysAllocString
Procedure helpSysAllocString(*Value)
  ProcedureReturn SysAllocString_(*Value)
EndProcedure
Prototype.l ProtoSysAllocString(Value.p-unicode)
;-T_BSTR
Global T_BSTR.ProtoSysAllocString = @helpSysAllocString()

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

Procedure.d T_DATE(pbDate)
  
  Protected date.d
  
  date = pbDate / 86400.0 + 25569.0
  ProcedureReturn date
  
EndProcedure

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

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, len - 2)
    LocalFree_(*Buffer)
    ProcedureReturn result
  Else
    ProcedureReturn "Errorcode: " + Hex(vhLastError)
  EndIf
  
EndProcedure

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

Procedure.s VT_STR(*Var.Variant)

  Shared vhLastError.l

  Protected vargDest.variant, hr, result.s
  
  If *Var
    hr = VariantChangeType_(vargDest, *Var, #LOCALE_NOUSEROVERRIDE, #VT_BSTR)
    If hr = #S_OK
      result = PeekS(vargDest\bstrVal, #PB_Any, #PB_Unicode)
      VariantClear_(vargDest)
      ProcedureReturn result
    
    Else
      vhLastError = hr
      ProcedureReturn ""
    EndIf
    
  EndIf
EndProcedure
  
; ***************************************************************************************
  
Procedure.l VT_BOOL(*Var.Variant)

  Shared vhLastError.l
  
  Protected result.l

  If *Var
    Select *Var\vt
      Case #VT_BOOL
        result = *Var\boolVal
      Case #VT_I1, #VT_UI1
        result = *Var\bVal
      Case #VT_I2, #VT_UI2
        result = *Var\iVal
      Case #VT_I4, #VT_UI4
        result = *Var\lVal
      Case #VT_I8, #VT_UI8
        result = *Var\llVal
      Case #VT_R4
        result = *Var\fltVal
      Case #VT_R8
         *Var\dblVal
      Default
        vhLastError = $80020008
        result = 0
    EndSelect
    If result
      ProcedureReturn #True
    Else
      ProcedureReturn #False
    EndIf
  EndIf
EndProcedure
  
; ***************************************************************************************

Procedure.b VT_BYTE(*Var.Variant)

  Shared vhLastError.l
  
  If *Var
    Select *Var\vt
      Case #VT_BOOL
        ProcedureReturn *Var\boolVal
      Case #VT_I1, #VT_UI1
        ProcedureReturn *Var\bVal
      Case #VT_I2, #VT_UI2
        ProcedureReturn *Var\iVal
      Case #VT_I4, #VT_UI4
        ProcedureReturn *Var\lVal
      Case #VT_I8, #VT_UI8
        ProcedureReturn *Var\llVal
      Case #VT_R4
        ProcedureReturn *Var\fltVal
      Case #VT_R8
        ProcedureReturn *Var\dblVal
      Case #VT_BSTR
        ProcedureReturn Val(PeekS(*Var\bstrVal, #PB_Any, #PB_Unicode))
          
      Default
        vhLastError = $80020008
        ProcedureReturn 0
      
    EndSelect
  EndIf
EndProcedure
  
; ***************************************************************************************

Procedure.w VT_WORD(*Var.Variant)

  Shared vhLastError.l
  
  If *Var
    Select *Var\vt
      Case #VT_BOOL
        ProcedureReturn *Var\boolVal
      Case #VT_I1, #VT_UI1
        ProcedureReturn *Var\bVal
      Case #VT_I2, #VT_UI2
        ProcedureReturn *Var\iVal
      Case #VT_I4, #VT_UI4
        ProcedureReturn *Var\lVal
      Case #VT_I8, #VT_UI8
        ProcedureReturn *Var\llVal
      Case #VT_R4
        ProcedureReturn *Var\fltVal
      Case #VT_R8
        ProcedureReturn *Var\dblVal
      Case #VT_BSTR
        ProcedureReturn Val(PeekS(*Var\bstrVal, #PB_Any, #PB_Unicode))
          
      Default
        vhLastError = $80020008
        ProcedureReturn 0
      
    EndSelect
  EndIf
EndProcedure
  
; ***************************************************************************************

Procedure.l VT_LONG(*Var.Variant)

  Shared vhLastError.l
  
  If *Var
    Select *Var\vt
      Case #VT_BOOL
        ProcedureReturn *Var\boolVal
      Case #VT_I1, #VT_UI1
        ProcedureReturn *Var\bVal
      Case #VT_I2, #VT_UI2
        ProcedureReturn *Var\iVal
      Case #VT_I4, #VT_UI4
        ProcedureReturn *Var\lVal
      Case #VT_I8, #VT_UI8
        ProcedureReturn *Var\llVal
      Case #VT_R4
        ProcedureReturn *Var\fltVal
      Case #VT_R8
        ProcedureReturn *Var\dblVal
      Case #VT_BSTR
        ProcedureReturn Val(PeekS(*Var\bstrVal, #PB_Any, #PB_Unicode))
          
      Default
        vhLastError = $80020008
        ProcedureReturn 0
      
    EndSelect
  EndIf
EndProcedure
  
; ***************************************************************************************

Procedure.q VT_QUAD(*Var.Variant)

  Shared vhLastError.l
  
  If *Var
    Select *Var\vt
      Case #VT_BOOL
        ProcedureReturn *Var\boolVal
      Case #VT_I1, #VT_UI1
        ProcedureReturn *Var\bVal
      Case #VT_I2, #VT_UI2
        ProcedureReturn *Var\iVal
      Case #VT_I4, #VT_UI4
        ProcedureReturn *Var\lVal
      Case #VT_I8, #VT_UI8
        ProcedureReturn *Var\llVal
      Case #VT_R4
        ProcedureReturn *Var\fltVal
      Case #VT_R8
        ProcedureReturn *Var\dblVal
      Case #VT_BSTR
        ProcedureReturn ValQ(PeekS(*Var\bstrVal, #PB_Any, #PB_Unicode))
          
      Default
        vhLastError = $80020008
        ProcedureReturn 0
      
    EndSelect
  EndIf
EndProcedure
  
; ***************************************************************************************

Procedure.f VT_FLOAT(*Var.Variant)

  Shared vhLastError.l
  
  If *Var
    Select *Var\vt
      Case #VT_BOOL
        ProcedureReturn *Var\boolVal
      Case #VT_I1, #VT_UI1
        ProcedureReturn *Var\bVal
      Case #VT_I2, #VT_UI2
        ProcedureReturn *Var\iVal
      Case #VT_I4, #VT_UI4
        ProcedureReturn *Var\lVal
      Case #VT_I8, #VT_UI8
        ProcedureReturn *Var\llVal
      Case #VT_R4
        ProcedureReturn *Var\fltVal
      Case #VT_R8
        ProcedureReturn *Var\dblVal
      Case #VT_BSTR
        ProcedureReturn ValF(PeekS(*Var\bstrVal, #PB_Any, #PB_Unicode))
          
      Default
        vhLastError = $80020008
        ProcedureReturn 0
      
    EndSelect
  EndIf
EndProcedure
  
; ***************************************************************************************

Procedure.d VT_DOUBLE(*Var.Variant)

  Shared vhLastError.l
  
  If *Var
    Select *Var\vt
      Case #VT_BOOL
        ProcedureReturn *Var\boolVal
      Case #VT_I1, #VT_UI1
        ProcedureReturn *Var\bVal
      Case #VT_I2, #VT_UI2
        ProcedureReturn *Var\iVal
      Case #VT_I4, #VT_UI4
        ProcedureReturn *Var\lVal
      Case #VT_I8, #VT_UI8
        ProcedureReturn *Var\llVal
      Case #VT_R4
        ProcedureReturn *Var\fltVal
      Case #VT_R8
        ProcedureReturn *Var\dblVal
      Case #VT_BSTR
        ProcedureReturn ValD(PeekS(*Var\bstrVal, #PB_Any, #PB_Unicode))
          
      Default
        vhLastError = $80020008
        ProcedureReturn 0
      
    EndSelect
  EndIf
EndProcedure
  
; ***************************************************************************************

Procedure.l VT_DATE(*Var.Variant) ; PB-Datum

  Shared vhLastError.l
  
  Protected pbDate
  
  If *Var
    Select *Var\vt
      Case #VT_DATE
        pbDate = (*Var\dblVal  - 25569.0) * 86400.0
        ProcedureReturn pbDate
      Default
        vhLastError = $80020008
        ProcedureReturn 0
      
    EndSelect
  EndIf
EndProcedure
  
; ***************************************************************************************

Procedure.l GetVariantSafeArrayCount(*Var.Variant)
  Protected result.l, *array.safearray
  If *Var
    If (*Var\vt & #VT_ARRAY) = #VT_ARRAY
      *array = *Var\parray
      result = *array\rgsabound\cElements
    Else
      result = 0
    EndIf
  Else
    result = 0
  EndIf
  ProcedureReturn result
EndProcedure

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

Procedure.l GetVariantSafeArrayVarType(*Var.Variant)
  Protected result.l, *array.safearray
  If *Var
    result = *Var\vt & $1FFF
  Else
    result = 0
  EndIf
  ProcedureReturn result
EndProcedure

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

Procedure.l GetVariantSafeArray(*Var.Variant)
  Protected result.l, *array.safearray
  If *Var
    If (*Var\vt & #VT_ARRAY) = #VT_ARRAY
      *array = *Var\parray
      result = *array\pvdata
    Else
      result = 0
    EndIf
  Else
    result = 0
  EndIf
  ProcedureReturn result
EndProcedure

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

Macro V_EMPTY(Arg)
  VariantClear_(Arg)
  Arg\vt = #VT_EMPTY
  arg\llVal = 0
EndMacro

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

Macro V_NULL(Arg)
  VariantClear_(Arg)
  Arg\vt = #VT_NULL
  arg\bstrVal
EndMacro

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

Macro V_DISP(Arg)
  VariantClear_(Arg)
  Arg\vt = #VT_DISPATCH
  arg\pdispVal
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

; ***************************************************************************************
Update:
- vhGetLastMessage()
- vhGetLastError()
- VT_STR(...)


Thanks to freak

GT :wink:
All times are UTC+01:00
Page 7 of 18

Powered by phpBB® Forum Software © phpBB Limited