PureDispHelper UserLib - Update with Includefile for Unicode
@freak:
thanks for your fast support!
@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.
Greetings ... Kiffi
thanks for your fast support!
@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
- DoubleDutch
- Addict
- Posts: 3219
- Joined: Thu Aug 07, 2003 7:01 pm
- Location: United Kingdom
- Contact:
Wow! Just seen this thread. Great work!
https://deluxepixel.com <- My Business website
https://reportcomplete.com <- School end of term reports system
https://reportcomplete.com <- School end of term reports system
Question ...
Is this the correct way of using the date structure ?
The result is always december
Thanks.
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)
LuckyLuke
Solved the problem ...
I have to use the string parameter for date... strange, but it works
Thanks for this great lib. It opens a new world for PureBasic users.
I have to use the string parameter for date... strange, but it works
Code: Select all
dhCallMethod(DayView, "ShowDay(%s)", @"31/12/2007")
LuckyLuke
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.
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.
PureBasic 5.73 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 20.1 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
I have a problem with Open Office org automation
It seems that this instruction make a crash
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
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 )
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
This parameter isn't a bool, so test it with %dKIKI wrote: Type Mismatch "LoadcomponentFromurl.argument.index:3
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()
Add this line to the end of source:
Code: Select all
dhUninitialize()
PureBasic 5.73 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 20.1 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Small example using Disphelper_Include
works with include in Unicode and ANSI mode
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
PureBasic 5.73 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 20.1 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
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:
Example:
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
; ***************************************************************************************
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()
PureBasic 5.73 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 20.1 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
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.
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.
quidquid Latine dictum sit altum videtur
Ok,
Is in work
Thanks
FF
Is in work
Thanks
FF
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
thanks to all helpers
PureBasic 5.73 | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 20.1 (x64)
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Old bugs good, new bugs bad! Updates are evil: might fix old bugs and introduce no new ones.
Now Update for VariantHelper
Update:
- vhGetLastMessage()
- vhGetLastError()
- VT_STR(...)
Thanks to freak
GT
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
; ***************************************************************************************
- vhGetLastMessage()
- vhGetLastError()
- VT_STR(...)
Thanks to freak
GT
My Projects ThreadToGUI / OOP-BaseClass / EventDesigner V3
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive
PB v3.30 / v5.75 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace / OneDrive