PureDispHelper UserLib - Update with Includefile for Unicode

Applications, Games, Tools, User libs and useful stuff coded in PureBasic
User avatar
ts-soft
Always Here
Always Here
Posts: 5756
Joined: Thu Jun 24, 2004 2:44 pm
Location: Berlin - Germany

Post by ts-soft »

Here the same example as MediaPlayer.pb, but using QuickTime!

Code: Select all

EnableExplicit

dhToggleExceptions(#True)

Define.l oQT
Define.s MediaPath = "http://www.blitzbasement.net/bank/aliensong.mpeg"

If OpenWindow(0, #PB_Ignore, #PB_Ignore, 320, 255,"QuickTime - Demo") And CreateGadgetList(WindowID(0))
  oQT = OCX_CreateGadget(0, 0, 0, 320, 255, "QTOControl.QTControl.1")
  If oQT
  
    dhPutValue(oQT, "FileName = %s", @MediaPath)
    dhPutValue(oQT, "AutoPlay = %b", #True)
    
  EndIf
  
  While WaitWindowEvent() ! 16 : Wend
  
  If oQT : dhCallMethod(oQT, "ShowAboutBox") : dhReleaseObject(oQT) : EndIf
  
  CloseWindow(0)
EndIf
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.
Image
Dare
Addict
Addict
Posts: 1965
Joined: Mon May 29, 2006 1:01 am
Location: Outback

Post by Dare »

Hi ts-soft

I don't want to bog this thread down with questions and bug reports, etc.

And I don't want to waste your time or put work on you.

How do you want to handle that sort of thing?

Thanks.
Dare2 cut down to size
User avatar
ts-soft
Always Here
Always Here
Posts: 5756
Joined: Thu Jun 24, 2004 2:44 pm
Location: Berlin - Germany

Post by ts-soft »

This thread is for questions and bugreports :wink:
But i can't help at all, and my english is very bad.
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.
Image
Dare
Addict
Addict
Posts: 1965
Joined: Mon May 29, 2006 1:01 am
Location: Outback

Post by Dare »

Okay, using ADO.

Code: Select all

Structure udt_ado
  Conn.l     ; Connection object
  RS.l       ; RecordSet object
  EOF.l      ; End of File, Beginning of File flag
EndStructure

global oSrc.udt_ado

; yada yada

Procedure.s rsValue(*o.udt_ado, fld.s)               ; Get field data by field name
  Protected adr.l=0
  Protected dta.s
  dhGetValue("%s", @adr, *o\RS, ".Fields(%s).Value", @fld)
  If adr
    dta=PeekS(adr)
  Else
    dta=Chr(1)+"ERROR"+Chr(1)
  EndIf
  dhFreeString(adr)
  ProcedureReturn dta
EndProcedure

;yada yada

; Inside a loop (through recordset) things like this:
  sql + "someField='" + rsValue(@oSrc,"pCost") + "',"
  sql + "anotherField='ABC',"
; Intermittently fails.
This sometimes returns the string which seems to include a trailing null or other character that throws things because the sql ends up as containing:

Code: Select all

someField='VALUEanotherField='ABC',
Sometimes.

Other times

Code: Select all

someField='VALUE',anotherField='ABC',
So it is intermittentant.

And if this is done:

Code: Select all

  w.s = rsValue(@oSrc,"pCost")
  x.s = w
  sql + "someField='" + x + "',"
  sql + "anotherField='ABC',"
the "sql" string always looks okay.

Code: Select all

someField='VALUE',anotherField='ABC',
XP pro, PB 4.02, neither Unicode nor Threadsafe in use. Is not using unicode likely to be a problem?

Edit: The text fields in the access database are set for unicode compression.

I would give you the DB but I can't as it contains real information for a real company. I have copied it, "repaired" the copy (via ODBC control panel) and via ASP. The DB is readable using normal PB database commands and via ASP.
Dare2 cut down to size
User avatar
Joakim Christiansen
Addict
Addict
Posts: 2452
Joined: Wed Dec 22, 2004 4:12 pm
Location: Norway
Contact:

Post by Joakim Christiansen »

ts-soft wrote:Here the same example as MediaPlayer.pb, but using QuickTime!
Nice, now we need one with RealPlayer too! :P
I like logic, hence I dislike humans but love computers.
User avatar
ts-soft
Always Here
Always Here
Posts: 5756
Joined: Thu Jun 24, 2004 2:44 pm
Location: Berlin - Germany

Post by ts-soft »

@Dare
With Ado, i hope Kiffi can help you.

I think there a problems with the pointers. The object isn't a long, is a pointer
to IDispatch-Interface. But ... ???

@Joakim Christiansen
I have no Realplayer installed, so i can't help with this. But should not a problem
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.
Image
Dare
Addict
Addict
Posts: 1965
Joined: Mon May 29, 2006 1:01 am
Location: Outback

Post by Dare »

ts-soft wrote:@Dare
With Ado, i hope Kiffi can help you.
Okay mate, thanks. :)
ts-soft wrote:I think there a problems with the pointers. The object isn't a long, is a pointer to IDispatch-Interface. But ... ???
Should I represent that (Conn and RS in the structure) in a different way?
Dare2 cut down to size
User avatar
Joakim Christiansen
Addict
Addict
Posts: 2452
Joined: Wed Dec 22, 2004 4:12 pm
Location: Norway
Contact:

Post by Joakim Christiansen »

ts-soft wrote:@Joakim Christiansen
I have no Realplayer installed, so i can't help with this. But should not a problem
Okay, maybe I'll try myself then, but need to find documentation for this.
I see that I can use COM instead of a WebGadget in my TV player now. :D
I like logic, hence I dislike humans but love computers.
User avatar
ts-soft
Always Here
Always Here
Posts: 5756
Joined: Thu Jun 24, 2004 2:44 pm
Location: Berlin - Germany

Post by ts-soft »

Dare wrote:Should I represent that (Conn and RS in the structure) in a different way?
Your structure is global, use it, without the pointer. I don't know, test it.

The converting stuff from ansi to unicode, bstr or variant is handled by the
imported lib, so i can't do anything with this.
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.
Image
Dare
Addict
Addict
Posts: 1965
Joined: Mon May 29, 2006 1:01 am
Location: Outback

Post by Dare »

Hi mate,

Okay, I will try some other ways. The procedure, btw, is used for several DBs and connections open at the same time all with own associated structures (I was lazy to type everything out so made a proc :) - I will try with a macro)

I appreciate your help and the lib. Thanks!
Dare2 cut down to size
freak
PureBasic Team
PureBasic Team
Posts: 5929
Joined: Fri Apr 25, 2003 5:21 pm
Location: Germany

Post by freak »

Catching events is possible by implementing a "sink" interface and connecting it
to the object. I hacked together some code for this:

Includefile:

Code: Select all

; ---------------------------------------------------------------------
;
; Receive COM events from ActiveX controls
;
; 26.4.07 by Timo 'fr34k' Harter
;
; ---------------------------------------------------------------------
;
; Connection = OCX_ConnectEvents(Object, @EventCallback())
;
;   Connects the callback to the Object. Returns an ID if successful
;   that can be used to disconnect the callback again.
;   If the callback is not disconnected before the object is distroyed, this is
;   done automatically.
;
;   Returns 0 if the connection failed.
;
;   NOTE: The Object must expose a ConnectionPoint, and it must provide
;         information about it through a type library!
; 
;
; OCX_DisconnectEvents(Object, Connection)
;
;   Disconnects a previous set event callback from the object.
;   If the callback is not disconnected before the object is distroyed, this is
;   done automatically.
;
; The Callback has to look like this:
;
;   Procedure EventCallback(Event$, ParameterCount, *Parameters)
;   EndProcedure
;
;   Event$         - the name of the event
;   ParameterCount - the number of parameters for the event
;   *Parameters    - the parameter list. the functions below can be used to access this
;
; OCX_EventLong(*Parameters, index)
; OCX_EventFloat(*Parameters, index)
; OCX_EventQuad(*Parameters, index)
; OCX_EventDouble(*Parameters, index)
; OCX_EventString(*Parameters, index)
; OCX_EventObject(*Parameters, index)
;
;   Returns the parameter at position 'index' (one-based) in form of a
;   long, float, quad, double, string or object.
;   These functions are only valid inside the callback with the *Parameters parameter.
;
;   For OCX_EventObject(), the returned object must be released!
;
; ---------------------------------------------------------------------

EnableExplicit

Prototype EventCallback(EventName$, ParameterCount, *Parameters)

Structure EventSink
  *Vtbl.l
  RefCount.l  
  ConnIID.IID
  TypeInfo.ITypeInfo
  Callback.EventCallback
EndStructure 

Procedure EventSink_QueryInterface(*THIS.EventSink, *IID.IID, *Object.LONG)  
  If CompareMemory(*IID, ?IID_IUnknown, SizeOf(IID)) Or CompareMemory(*IID, ?IID_IDispatch, SizeOf(IID)) Or CompareMemory(*IID, @*THIS\ConnIID, SizeOf(IID))
    *Object\l = *THIS
    *THIS\RefCount + 1
    ProcedureReturn #S_OK
  Else
    *Object\l = 0
    ProcedureReturn #E_NOINTERFACE
  EndIf
EndProcedure

Procedure EventSink_AddRef(*THIS.EventSink)
  *THIS\RefCount + 1
  ProcedureReturn *THIS\RefCount
EndProcedure

Procedure EventSink_Release(*THIS.EventSink)
  *THIS\RefCount - 1
  
  If *THIS\RefCount = 0
    *THIS\TypeInfo\Release()
    FreeMemory(*THIS)
    ProcedureReturn 0
  Else  
    ProcedureReturn *THIS\RefCount
  EndIf
EndProcedure

Procedure EventSink_GetTypeInfoCount(*THIS.EventSink, *pctinfo.LONG)
  *pctinfo\l = 1
  ProcedureReturn #S_OK
EndProcedure

Procedure EventSink_GetTypeInfo(*THIS.EventSink, iTInfo, lcid, *ppTInfo.LONG)
  *ppTInfo\l = *THIS\TypeInfo
  *THIS\TypeInfo\AddRef()
  ProcedureReturn #S_OK
EndProcedure

Procedure EventSink_GetIDsOfNames(*THIS.EventSink, *riid, *rgszNames, *cNames, lcid, *DispID)
  ProcedureReturn DispGetIDsOfNames_(*THIS\TypeInfo, *rgszNames, *cNames, *DispID)
EndProcedure

Procedure EventSink_Invoke(*THIS.EventSink, dispid, *riid, lcid, wflags.w, *Params.DISPPARAMS, *Result.VARIANT, *pExept, *ArgErr)
  Protected NameCount, bstrName
  Protected Callback.EventCallback = *THIS\Callback ; work around a compiler bug
 
  If Callback And *THIS\TypeInfo\GetNames(dispid, @bstrName, 1, @NameCount) = #S_OK And bstrName
    Callback(PeekS(bstrName, -1, #PB_Unicode), *Params\cArgs + *Params\cNamedArgs, *Params)
    SysFreeString_(bstrName)   
  EndIf
 
  ProcedureReturn #S_OK 
EndProcedure

; ---------------------------------------------------------------------

Procedure.l OCX_EventLong(*Params.DISPPARAMS, index)
  Protected Value.VARIANT, puArgErr
  
  If index > 0 And index <= *Params\cArgs+*Params\cNamedArgs
    DispGetParam_(*Params, index-1, #VT_I4, @Value, @puArgErr)
  EndIf
  
  ProcedureReturn Value\lVal
EndProcedure

Procedure.f OCX_EventFloat(*Params.DISPPARAMS, index)
  Protected Value.VARIANT, puArgErr
  
  If index > 0 And index <= *Params\cArgs+*Params\cNamedArgs
    DispGetParam_(*Params, index-1, #VT_R4, @Value, @puArgErr)
  EndIf
  
  ProcedureReturn Value\fltVal
EndProcedure

Procedure.q OCX_EventQuad(*Params.DISPPARAMS, index)
  Protected Value.VARIANT, puArgErr
  
  If index > 0 And index <= *Params\cArgs+*Params\cNamedArgs
    DispGetParam_(*Params, index-1, #VT_I8, @Value, @puArgErr)
  EndIf
  
  ProcedureReturn Value\llVal
EndProcedure

Procedure.d OCX_EventDouble(*Params.DISPPARAMS, index)
  Protected Value.VARIANT, puArgErr
  
  If index > 0 And index <= *Params\cArgs+*Params\cNamedArgs
    DispGetParam_(*Params, index-1, #VT_R8, @Value, @puArgErr)
  EndIf
  
  ProcedureReturn Value\dblVal
EndProcedure

Procedure.s OCX_EventString(*Params.DISPPARAMS, index)
  Protected Value.VARIANT, puArgErr
  Protected Result$ = ""
  
  If index > 0 And index <= *Params\cArgs+*Params\cNamedArgs
    If DispGetParam_(*Params, index-1, #VT_BSTR, @Value, @puArgErr) = #S_OK
      If Value\bstrVal
        Result$ = PeekS(Value\bstrVal, -1, #PB_Unicode)
        SysFreeString_(Value\bstrVal)
      EndIf
    EndIf
  EndIf
  
  ProcedureReturn Result$
EndProcedure

Procedure.l OCX_EventObject(*Params.DISPPARAMS, index)
  Protected Value.VARIANT, puArgErr
  
  If index > 0 And index <= *Params\cArgs+*Params\cNamedArgs
    DispGetParam_(*Params, index-1, #VT_DISPATCH, @Value, @puArgErr)
  EndIf
  
  ProcedureReturn Value\pdispVal
EndProcedure

; ---------------------------------------------------------------------

Procedure OCX_ConnectEvents(Object.IUnknown, Callback.EventCallback)  
  Protected Container.IConnectionPointContainer
  Protected Connection.IConnectionPoint
  Protected Enum.IEnumConnectionPoints
  Protected Dispatch.IDispatch, TypeLib.ITypeLib
  Protected DispTypeInfo.ITypeInfo, TypeInfo.ITypeInfo
  Protected ConnIID.IID, *NewSink.EventSink, NewSink.IDispatch
  Protected InfoCount = 0, index, Result = 0

  If Object\QueryInterface(?IID_IConnectionPointContainer, @Container.IConnectionPointContainer) = #S_OK
    If Container\EnumConnectionPoints(@Enum.IEnumConnectionPoints) = #S_OK
      If Enum\Reset() = #S_OK And Enum\Next(1, @Connection.IConnectionPoint, #Null) = #S_OK      
        If Connection\GetConnectionInterface(@ConnIID.IID) = #S_OK
        
          If Object\QueryInterface(?IID_IDispatch, @Dispatch.IDispatch) = #S_OK          
            If Dispatch\GetTypeInfoCount(@InfoCount) = #S_OK And InfoCount = 1
              If Dispatch\GetTypeInfo(0, 0, @DispTypeInfo.ITypeInfo) = #S_OK
                If DispTypeInfo\GetContainingTypeLib(@TypeLib.ITypeLib, @index) = #S_OK
                  If TypeLib\GetTypeInfoOfGuid(@ConnIID, @TypeInfo.ITypeInfo) = #S_OK
                    
                    *NewSink.EventSink = AllocateMemory(SizeOf(EventSink))                      
                    If *NewSink
                      *NewSink\Vtbl     = ?EventSink_Vtbl
                      *NewSink\RefCount = 1
                      *NewSink\TypeInfo = TypeInfo
                      *NewSink\Callback = Callback
                      *NewSink\TypeInfo\AddRef()
                      CopyMemory(@ConnIID, @*NewSink\ConnIID, SizeOf(IID))
                      NewSink.IDispatch = *NewSink
                    
                      Connection\Advise(NewSink, @Result)
                      NewSink\Release()
                    EndIf

                    TypeInfo\Release()
                  EndIf               
                  TypeLib\Release()
                EndIf                
                DispTypeInfo\Release()
              EndIf
            EndIf                    
            Dispatch\Release()
          EndIf
        
        EndIf        
        Connection\Release()
      EndIf
      Enum\Release()
    EndIf
    Container\Release()
  EndIf
  
  ProcedureReturn Result
EndProcedure

Procedure OCX_DisconnectEvents(Object.IUnknown, EventConnection)
  Protected Container.IConnectionPointContainer
  Protected Connection.IConnectionPoint
  Protected Enum.IEnumConnectionPoints
  
  If Object\QueryInterface(?IID_IConnectionPointContainer, @Container.IConnectionPointContainer) = #S_OK
    If Container\EnumConnectionPoints(@Enum.IEnumConnectionPoints) = #S_OK
      If Enum\Reset() = #S_OK And Enum\Next(1, @Connection.IConnectionPoint, #Null) = #S_OK      
        Connection\Unadvise(EventConnection)
        Connection\Release()
      EndIf
      Enum\Release()
    EndIf
    Container\Release()
  EndIf        
EndProcedure

; ---------------------------------------------------------------------

DataSection
  EventSink_Vtbl:
    Data.l @EventSink_QueryInterface()
    Data.l @EventSink_AddRef()
    Data.l @EventSink_Release()
    Data.l @EventSink_GetTypeInfoCount()
    Data.l @EventSink_GetTypeInfo()
    Data.l @EventSink_GetIDsOfNames()
    Data.l @EventSink_Invoke()    

  IID_IUnknown: ; {00000000-0000-0000-C000-000000000046}
    Data.l $00000000
    Data.w $0000, $0000
    Data.b $C0, $00, $00, $00, $00, $00, $00, $46

  IID_IDispatch: ; {00020400-0000-0000-C000-000000000046}
    Data.l $00020400
    Data.w $0000, $0000
    Data.b $C0, $00, $00, $00, $00, $00, $00, $46   
    
  IID_IConnectionPointContainer: ; {B196B284-BAB4-101A-B69C-00AA00341D07}
    Data.l $B196B284
    Data.w $BAB4, $101A
    Data.b $B6, $9C, $00, $AA, $00, $34, $1D, $07
    
EndDataSection
One of the RMChart examples with events:

Code: Select all

; example by ts-soft

EnableExplicit

XIncludeFile "ComEventSink.pb"

Procedure EventCallback(Event$, ParameterCount, *Params)
  Debug Event$
  
  If ParameterCount = 5
    Debug "  Button: " + Str(OCX_EventLong(*Params, 1))
    Debug "  X: " + Str(OCX_EventLong(*Params, 3))
    Debug "  Y: " + Str(OCX_EventLong(*Params, 4))
  EndIf
  
  Debug ""
EndProcedure

Define.l oRMChart
Define.s bars, tmp

Restore bars
Repeat
  Read tmp
  bars + tmp
Until tmp = ""

dhToggleExceptions(#True)

If OpenWindow(0, #PB_Ignore, #PB_Ignore, 550, 300, "RMChart loaded as string from Datasection") And CreateGadgetList(WindowID(0))
 
  oRMChart = OCX_CreateGadget(1, 0, 0, 550, 300, "RMChart.RMChartX")
 
  If oRMChart
    dhPutValue(oRMChart, ".RMCFile = %s", @bars)
    dhPutValue(oRMChart, ".RMCUserWatermark = %s", @"PureBasic")
    dhCallMethod(oRMChart, ".Draw")
   
    OCX_ConnectEvents(oRMChart, @EventCallback())   
  EndIf
 
  While WaitWindowEvent() ! 16 : Wend
 
  CloseWindow(0)
 
  If oRMChart : dhReleaseObject(oRMChart) : EndIf
 
EndIf

DataSection
  bars:
  Data.s "00003550|00004300|000051|000073|00008-2894893|00009310|00011Tahoma|100011|100035|100045|10005-5|10006-5"
  Data.s "|1000911|100101|100111|100131|100181|100201|1002113|1002213|100238|100331|100341|100356|100378|100411"
  Data.s "|100468|100482|10052-16777216|10053-1120086|100544|100555|10056-16777216|10057-16777216|10060-16777216"
  Data.s "|10061-16777216|1006316|10064-5383962|100652|10066-16777011|10181Birth of a Killer App|10182Schedule*Reality"
  Data.s "|10187Design*Development*Testing*Bug Fixing*Documentation*Marketing|1020104/01*04/02*04/03*04/04*04/05*04"
  Data.s "/06*04/07*04/08*04/09*04/10*04/11*04/12*05/01|110011|110026|110044|110101|110131|11019-6751336|1102111|110221"
  Data.s "|1102312|110531*3*4*6*6*4*7*4*9*3*10*3|120011|120026|120044|120101|120132|12019-47872|1202111|120221|1202312"
  Data.s "|120531*.5*1.5*10.5*12*1*12*1*12.5*.5*2*11"
  Data.s ""
EndDataSection
@ts-soft:
If you want to include this in your library, you have my permission.
The code should probably get some more testing first though.

Damn, tomorrows lectures will be hard. not enough sleep left... :)
Last edited by freak on Thu Apr 26, 2007 9:49 pm, edited 1 time in total.
quidquid Latine dictum sit altum videtur
User avatar
ts-soft
Always Here
Always Here
Posts: 5756
Joined: Thu Jun 24, 2004 2:44 pm
Location: Berlin - Germany

Post by ts-soft »

freak wrote: @ts-soft:
If you want to include this in your library, you have my permission.
The code should probably get some more testing first though.
Image
Thanks for this
freak wrote: Damn, tomorrows lectures will be hard. not enough sleep left... :)
gute n8 :D
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.
Image
techjunkie
Addict
Addict
Posts: 1126
Joined: Wed Oct 15, 2003 12:40 am
Location: Sweden
Contact:

Post by techjunkie »

Wow! This is a very cool UserLib!! :!: :!: :D Thank you!
Image
(\__/)
(='.'=) This is Bunny. Copy and paste Bunny into your
(")_(") signature to help him gain world domination.
Dare
Addict
Addict
Posts: 1965
Joined: Mon May 29, 2006 1:01 am
Location: Outback

Post by Dare »

Hi,

Just for info for anyone interested.

Further to the ADO problem above. It is not as random as I first thought. It happens when:
  • A table with data has a column added via the access control panel. (Maybe also on the fly?)
    The column is text, and allows zero length data, is not a required field, is unicode compressed.
    No data is assigned to that column during any processing.
    Querying the db and retrieving the field value then causes a "data type" error.
Adding data to the field removes the error. Even if an empty string is added, eg UPDATE products SET newfld='' WHERE code='whatever'.

So there is perhaps some issue with null strings?

Anyhow, it was easy to work around so for me no issue now. (Not sure how to get to the underlying problem though.)
Dare2 cut down to size
User avatar
Kiffi
Addict
Addict
Posts: 1353
Joined: Tue Mar 02, 2004 1:20 pm
Location: Amphibios 9

Post by Kiffi »

freak wrote:Catching events is possible by implementing a "sink" interface and connecting
it to the object.
Image Image Image

thanks a lot for your support! :D

Greetings ... Kiffi
Post Reply