It is currently Sat Oct 31, 2020 9:10 pm

All times are UTC + 1 hour




Post new topic Reply to topic  [ 1 post ] 
Author Message
 Post subject: COM TypeLibrary Importer - 'C' to PB
PostPosted: Fri Jul 31, 2020 11:53 pm 
Offline
Addict
Addict
User avatar

Joined: Fri May 12, 2006 6:51 pm
Posts: 2690
Location: Germany
Unfortunately the TypeLib importers for Purebasic 'OLE/COM Generator' and 'Interfaces Importer' are very old and still have errors. Also there is no code for them.

But the one from Pellen-C is very good and creates a COM type library file. Here a big thanks to Pelle.

This can be converted to Purebasic with the tool. I have tested this with the OPC automation interface.
But it must be extended in the tool surely still some things.

Update 1.01.1
- Bugfix ByVal Variant_Bool

ComTypeLibImporter.pb
Code:
;-TOP

; Comment : COM TypeLibrary Importer ('C' -> PB)
; Author  : mk-soft
; Version : v1.01.1
; Create  : 31.07.2020

EnableExplicit

Global NewList Lines.s()
Global NewList Interfaces.s()
Global NewList Enumerations.s()
Global NewList GUIDs.s()

Macro AddElementValue(_List_, _Value_)
  AddElement(_List_) : _List_ = _Value_
EndMacro

; ++++

Procedure SplitParameters(Line.s, Array Args.s(1), Part = 1)
  Protected param.s, index, cnt, pos
 
  For index = 1 To Part
    pos = FindString(Line, "(", pos)
    If pos
      pos + 1
    EndIf
  Next
  param = Mid(Line, pos)
  pos = FindString(param, ")")
  If pos
    param = Left(param, pos - 1)
  EndIf
 
  cnt = CountString(param, ",")
  Dim Args(cnt)
  For index = 0 To cnt
    Args(index) = Trim(StringField(param, index + 1, ","))
  Next
  ProcedureReturn cnt + 1
EndProcedure

; ++++

Procedure OpenTypeLibFile(FileName.s, List Result.s())
  Protected file, bom
  file = ReadFile(#PB_Any, FileName)
  If Not file
    ProcedureReturn 0
  EndIf
  ClearList(Result())
  bom = ReadStringFormat(file)
  While Not Eof(file)
    AddElement(Result())
    Result() = ReadString(file, bom)
  Wend
  CloseFile(file)
  ProcedureReturn ListSize(Result())
EndProcedure

; ----

Procedure FindEnumerations(List Lines.s(), List Result.s())
  Protected line.s, find, cnt
 
  ClearList(Result())
  AddElementValue(Result(), "; *** Constants ***")
  AddElementValue(Result(), "")
 
  ForEach Lines()
    line = Lines()
    If Not find And FindString(LCase(Line), "typedef enum ")
      find = #True
      cnt + 1
      line = Trim(line)
      line = Trim(line, #TAB$)
      line = RTrim(line, "{")
      line = RTrim(line)
      line = ReplaceString(line, "typedef enum", "Enumeration")
      AddElementValue(Result(), line)
      Continue
    EndIf
    If find
      If FindString(line, "}")
        find = #False
        AddElementValue(Result(), "EndEnumeration")
        AddElementValue(Result(), "")
        Continue
      EndIf
      line = Trim(line)
      line = Trim(line, #TAB$)
      line = RTrim(line, ",")
      line = Trim(line)
      line = "  #" + line
      AddElementValue(Result(), line)
      Continue
    EndIf
  Next
  ProcedureReturn cnt
EndProcedure

; ----

Procedure FindGUIDs(List Lines.s(), List Result.s())
  Protected index, line.s, find, cnt, comment.s, temp.s
  Dim Args.s(0)
 
  ClearList(Result())
  AddElementValue(Result(), "; *** GUIDs ***")
  AddElementValue(Result(), "")
 
  AddElementValue(Result(), "DataSection")
  ForEach Lines()
    line = Lines()
    If FindString(UCase(Line), "/*")
      comment = "; " + line
      Continue
    EndIf
    If FindString(UCase(Line), "DEFINE_GUID")
      line = ReplaceString(line, "0x", "$")
      cnt + 1
      If SplitParameters(line, Args()) = 12
        AddElementValue(Result(), "  " + Args(0) + ": " + comment)
        AddElementValue(Result(), "  Data.l " + Args(1))
        AddElementValue(Result(), "  Data.w " + Args(2) + ", " + Args(3))
        temp = "  Data.b " + Args(4)
        For index = 5 To 11
          temp + ", " + Args(index)
        Next
        AddElementValue(Result(), temp)
        AddElementValue(Result(), "")
      EndIf
    EndIf
    comment = ""
  Next
  AddElementValue(Result(), "EndDataSection")
  AddElementValue(Result(), "")
 
  ProcedureReturn cnt
EndProcedure

; ----

Procedure.s ConvertParam(Line.s, Part = 1)
  Protected result.s, param.s, pos, cnt, index, arg.s
 
  For index = 1 To Part
    pos = FindString(Line, "(", pos)
    If pos
      pos + 1
    EndIf
  Next
  param = Mid(Line, pos)
  pos = FindString(param, ")")
  If pos
    param = Left(param, pos - 1)
  EndIf
  param = LCase(param)
  cnt = CountString(param, ",") + 1
  For index = 1 To cnt
    arg = Trim(StringField(param, index, ","))
    If arg = "this"
      Continue
    ElseIf Right(arg, 2) = "**"
      result + "*p_" + Left(arg, Len(arg) - 2)
    ElseIf Right(arg, 1) = "*"
      result + "*" + Left(arg, Len(arg) - 1)
    ElseIf arg = "bstr"
      result + arg + ".p-bstr"
    ElseIf arg = "variant"
      result + arg + ".p-variant"
    ElseIf arg = "variant_bool"
      result + arg + ".p-variant"
    Else
      result + arg
    EndIf
    If index < cnt
      result + ", "
    EndIf
  Next
  ProcedureReturn result
EndProcedure

Procedure FindInterfaces(List Lines.s(), List Result.s())
  Protected line.s, find, cnt, name.s, ext.s, *element, pos, param.s, info.s
 
  ClearList(Result())
  AddElementValue(Result(), "; *** Interfaces ***")
  AddElementValue(Result(), "")
 
  ForEach Lines()
    line = Lines()
    If Not find And FindString(UCase(Line), "DECLARE_INTERFACE")
      find = #True
      cnt + 1
      name = Mid(line, FindString(line, "(") + 1)
      name = Left(name, FindString(name, ")") - 1)
      *element = @Lines()
      While NextElement(Lines())
        line = Lines()
        If FindString(line, "}")
          Break
        EndIf
        If FindString(UCase(line), "RELEASE)")
          *element = @Lines()
          ext = " Extends IUnknown"
        EndIf
        If FindString(UCase(line), "INVOKE)")
          *element = @Lines()
          ext = " Extends IDispatch"
        EndIf
      Wend
      ChangeCurrentElement(Lines(), *element)
      AddElementValue(Result(), "CompilerIf Defined(" + name + ", #PB_Interface) = #False")
      AddElementValue(Result(), "  Interface " + name + ext)
      ext = ""
      Continue
    EndIf
    If find
      If FindString(line, "}")
        find = #False
        AddElementValue(Result(), "  EndInterface")
        AddElementValue(Result(), "CompilerEndIf")
        AddElementValue(Result(), "")
        Continue
      EndIf
      If FindString(UCase(line), "STDMETHOD")
        name = Mid(line, FindString(line, "(") + 1)
        name = Left(name, FindString(name, ")") - 1)
        If FindString(name, ",")
          info = " ; " + Trim(StringField(name, 1, ","))
          name = Trim(StringField(name, 2, ","))
        Else
          info = ""
        EndIf
        param = "(" + ConvertParam(line, 2) + ")"
        AddElementValue(Result(), "    " + name + param + info)
        Continue
      EndIf
    EndIf
  Next
  ProcedureReturn cnt
EndProcedure

; ----

Procedure Convert(sourceFile.s, destFile.s)
  Protected file
 
  If sourceFile = ""
    ProcedureReturn 0
  EndIf
 
  If destFile = ""
    ProcedureReturn 0
  EndIf
 
  If sourceFile = destFile
    ProcedureReturn 0
  EndIf
 
  If FileSize(destFile) >= 0
    If MessageRequester("Questions", "Overwrite file:" + #LF$ + destFile, #PB_MessageRequester_YesNo | #PB_MessageRequester_Warning) = #PB_MessageRequester_No
      ProcedureReturn 0
    EndIf
  EndIf
 
  If OpenTypeLibFile(sourceFile, Lines())
    FindEnumerations(Lines(), Enumerations())
    FindGUIDs(Lines(), GUIDs())
    FindInterfaces(Lines(), Interfaces())
    file = CreateFile(#PB_Any, destFile)
    If file
      WriteStringFormat(file, #PB_UTF8)
      WriteStringN(file, "; Created with COM TypeLibrary Importer ('C' -> PB) v1.01", #PB_UTF8)
      WriteStringN(file, "; ", #PB_UTF8)
      WriteStringN(file, "; Source: " + sourceFile, #PB_UTF8)
      WriteStringN(file, "; Create: " + FormatDate("%YYYY/%MM/%DD %HH:%II:%SS", Date()), #PB_UTF8)
      WriteStringN(file, "", #PB_UTF8)
      ForEach Interfaces()
        WriteStringN(file, Interfaces(), #PB_UTF8)
      Next
      ForEach Enumerations()
        WriteStringN(file, Enumerations(), #PB_UTF8)
      Next
      ForEach GUIDs()
        WriteStringN(file, GUIDs(), #PB_UTF8)
      Next
      CloseFile(file)
      ProcedureReturn 1
    Else
      MessageRequester("Error", "Create File" + #LF$ + destFile, #PB_MessageRequester_Error)
      ProcedureReturn 0
    EndIf
  Else
    MessageRequester("Error", "Open File" + #LF$ + sourceFile, #PB_MessageRequester_Error)
    ProcedureReturn 0
  EndIf
EndProcedure

   
; ****

;-Main Window

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

Enumeration FormWindow
  #Main
EndEnumeration

Enumeration FormGadget
  #MainTextSource
  #MainTextDest
  #MainStringSource
  #MainStringDest
  #MainButtonSource
  #MainButtonDest
  #MainCheckBox
  #MainButtonStart
  #MainButtonQuit
EndEnumeration

Enumeration FormStatusBar
  #MainStatusBar
EndEnumeration

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

Global sourceFile.s, destFile.s

Procedure Main()
  Protected event
 
  #MainWidth = 440
  #MainHeight = 190
  #MainStyle = #PB_Window_SystemMenu | #PB_Window_MaximizeGadget | #PB_Window_MinimizeGadget
 
  If OpenWindow(#Main, #PB_Ignore, #PB_Ignore, #MainWidth, #MainHeight, "COM TypeLibrary Importer ('C' -> PB)", #MainStyle)
    ;-- Create StatusBar
    CreateStatusBar(#MainStatusBar, WindowID(#Main))
    AddStatusBarField(#PB_Ignore)
    ;-- Create Gadget
    TextGadget(#MainTextSource, 10, 10+5, 90, 25, "TypeLib file:")
    TextGadget(#MainTextDest, 10, 45+5, 90, 25, "Converted file:")
    StringGadget(#MainStringSource, 100, 10, 290, 25, "", #PB_String_ReadOnly)
    StringGadget(#MainStringDest, 100, 45, 290, 25, "", #PB_String_ReadOnly)
    ButtonGadget(#MainButtonSource, 400, 10, 30, 25, "...")
    ButtonGadget(#MainButtonDest, 400, 45, 30, 25, "...")
    CheckBoxGadget(#MainCheckBox, 10, 80, 300, 25, "Prozess the whole directory")
    ButtonGadget(#MainButtonStart, 10, 120, 200, 30, "Start conversion")
    ButtonGadget(#MainButtonQuit, 440-210, 120, 200, 30, "Quit")
   
    ;-- EventLoop
    Repeat
      event = WaitWindowEvent()
      Select event
        Case #PB_Event_CloseWindow
          Break
        Case #PB_Event_Gadget
          Select EventGadget()
            Case #MainButtonSource
              sourceFile = OpenFileRequester("TypeLib Files", "", "", 0)
              If sourceFile
                SetGadgetText(#MainStringSource, sourceFile)
                If GetGadgetState(#MainCheckBox)
                  destFile = GetPathPart(sourceFile) + GetFilePart(sourceFile, #PB_FileSystem_NoExtension) + ".pbi"
                  SetGadgetText(#MainStringDest, destFile)
                EndIf
              EndIf
             
            Case #MainButtonDest
              If Not GetGadgetState(#MainCheckBox)
                destFile = SaveFileRequester("PB Files", "", "", 0)
                If destFile
                  SetGadgetText(#MainStringDest, destFile)
                EndIf
              EndIf
             
            Case #MainCheckBox
              If GetGadgetState(#MainCheckBox)
                destFile = GetPathPart(sourceFile) + GetFilePart(sourceFile, #PB_FileSystem_NoExtension) + ".pbi"
                SetGadgetText(#MainStringDest, destFile)
              EndIf
             
            Case #MainButtonStart
              StatusBarText(#MainStatusBar, 0, "Start ...")
              If Convert(sourceFile, destFile)
                StatusBarText(#MainStatusBar, 0, "Ready.")
              Else
                StatusBarText(#MainStatusBar, 0, "Error.")
              EndIf
             
            Case #MainButtonQuit
              Break
             
          EndSelect
         
      EndSelect
    ForEver
   
    ;-- ExitProgram
   
  EndIf
 
EndProcedure : Main()

_________________
My Projects ThreadToGUI / OOP-BaseClass / OOP-BaseClassDispatch / EventDesigner V3
PB v3.30 / v5.70 - OS Mac Mini OSX 10.xx - VM Window Pro / Linux Ubuntu
Downloads on my Webspace


Top
 Profile  
Reply with quote  
Display posts from previous:  Sort by  
Post new topic Reply to topic  [ 1 post ] 

All times are UTC + 1 hour


Who is online

Users browsing this forum: No registered users and 5 guests


You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum

Search for:
Jump to:  

 


Powered by phpBB © 2008 phpBB Group
subSilver+ theme by Canver Software, sponsor Sanal Modifiye