PureBasic Forums - English

Code: Select all

Enumeration
  #CLSCTX_INPROC_SERVER  = 1
  #CLSCTX_INPROC_HANDLER = 2
  #CLSCTX_LOCAL_SERVER   = 4 
  #CLSCTX_REMOTE_SERVER  = 16
  #CLSCTX_SERVER = (#CLSCTX_INPROC_SERVER | #CLSCTX_LOCAL_SERVER | #CLSCTX_REMOTE_SERVER)
EndEnumeration

Structure TYPEATTR 
  guid.GUID 
  lcid.l 
  dwReserved.l 
  memidConstructor.l 
  memidDestructor.l 
  lpstrSchema.l 
  cbSizeInstance.l 
  typekind.l 
  cFuncs.w 
  cVars.w 
  cImplTypes.w 
  cbSizeVft.w 
  cbAlignment.w 
  wTypeFlags.w 
  wMajorVerNum.w 
  wMinorVerNum.w 
  tdescAlias.l 
  idldescType.l 
EndStructure 

ProcedureDLL.s Uni2Ansi(unicodestr.l) ; Converts Unicode to normal (Ansi) string
  lenA = WideCharToMultiByte_(#CP_ACP, 0, unicodestr, -1, 0, 0, 0, 0);
  ansistr.s = Space(lenA)
  If (lenA > 0)
    WideCharToMultiByte_(#CP_ACP, 0, unicodestr, -1, @ansistr, lenA, 0, 0);
  EndIf
  ProcedureReturn ansistr
EndProcedure

ProcedureDLL.l Ansi2Uni(ansistr.s) ; Converts normal (Ansi) string to Unicode
  lenA.l = Len(ansistr)
  lenW = MultiByteToWideChar_(#CP_ACP, 0, ansistr, lenA, 0, 0)
  If (lenW > 0) ; Check whether conversion was successful
    unicodestr = SysAllocStringLen_(0, lenW)
    MultiByteToWideChar_(#CP_ACP, 0, ansistr, lenA, unicodestr, lenW)
    result = unicodestr
    ProcedureReturn result
  Else 
    ProcedureReturn 0
  EndIf
EndProcedure

ProcedureDLL.l CreateObject(ProgID.s) ; Creates COM object from ProgID

  err.l = CLSIDFromProgID_(Ansi2Uni(ProgID), @CLSID.GUID)
  If err <> #S_OK
    SetErrorNumber(err)
    End
  EndIf

  err.l = CoCreateInstance_(CLSID,0,#CLSCTX_SERVER,?IID_IDispatch,@oDispatch.IDispatch)
  If err <> #S_OK
    SetErrorNumber(err)
    End
  EndIf

  If oDispatch\GetTypeInfo(0,lcid,@oDispTypeInfo.ITypeInfo) = #S_OK
    If oDispTypeInfo\GetTypeAttr(@aTypeAttributes.l) = #S_OK
      *oTypeAttributes.TYPEATTR=aTypeAttributes
      IID_OBJECT = *oTypeAttributes\guid
      oDispTypeInfo\ReleaseTypeAttr(aTypeAttributes)
    EndIf
    oDispTypeInfo\Release()
  EndIf

  err.l = oDispatch\QueryInterface(IID_OBJECT,@object.l)
  If err <> #S_OK
    oDispatch\Release()
    SetErrorNumber(err)
    End
  EndIf
  oDispatch\Release()

  ProcedureReturn object
EndProcedure

ProcedureDLL ReleaseObject(object.l) ; Releases Object from memory
  *object.IUnknown = object
  *object\Release()
EndProcedure

ProcedureDLL COMLIB_Init()
  CoInitialize_(#Null) 
EndProcedure

ProcedureDLL COMLIB_End()
  CoUninitialize_()  
EndProcedure

DataSection
  IID_IDispatch:
  Data.l $00020400
  Data.w $0000, $0000
  Data.b $C0,$00,$00,$00,$00,$00,$00,$46
EndDataSection
  
DataSection
  IID_IUnknown:
  Data.l $00000000
  Data.w $0000, $0000
  Data.b $C0,$00,$00,$00,$00,$00,$00,$46
EndDataSection