PureBasic Forums - English

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

vbModule 2 Pure

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

Page 1 of 1

vbModule 2 Pure

Posted: Sun Jun 30, 2002 7:45 pm
by BackupUser
Code updated for 5.20+

Restored from previous forum. Originally posted by Rings.

very first version :)

Code: Select all

;
; VB ModuleCode Converter V0.1
;
; by S.Rings (  -CodeGuru-  )
;
;This tool is only to convert VisualBasic ModuleCode to Pure, no Forms

; Date:25/06/2002: implements first version
;     :26/06/2002: added Api-support
;     :30/06/2002: added Instr
;
;yes there is a lot to do, but most is done to make convertings easier.

Procedure Instr(Position,O.s,S.s);Find CasesSensitive like VB's one
  C.s=S:S2.s=LCase(C)
  C.s=O:O2.s=LCase(C)
  i=FindString(O2,S2,Position)
  ProcedureReturn i
EndProcedure

Procedure VB2PB(SFilename.s,DFilename.s)
  OpenConsole()
  PrintN("Converting "+ SFilename +" ("+Str(FileSize(SFilename))+" Bytes)")
  PrintN("to "+DFilename)
  
  Result=ReadFile(1,SFilename)
  Result=CreateFile(2,DFilename)
  NewList ApisCalls.s()
  
  If Result
    NotEOF=1
    Repeat
      line +1
      ConsoleLocate(10,4)
      PrintN("Processing line:"+Str(Line))
      ;PrintN(MyLine.s)
      MyLine.s=ReadString(1)
      
      If Trim(MyLine) <> ""
        MySize=mysize+Len(MyLine)+2
        ;PrintN(Str(Mysize))
        ;PrintN(Myline)
        MyLine=ReplaceString(MyLine,"'",";",1);Always set the remark to Pures ;
        MyLine=ReplaceString(MyLine,"REM",";",1)
        
        ;now the unknown ApiCalls(note them in the list and remove them from source)
        ApiFlag=0
        i=Instr(1,MyLine,"Declare ")
        If i>0
          t=Instr(i+1,MyLine,"Lib")
          AddElement(ApisCalls())
          ApisCalls()=Trim(Mid(MyLine,i+24,t-i-24))
          ;MessageRequester("Info",apiscalls(),0)     
          ApiFlag=1
          MyLine=";"+MyLine;Remark them, coz we do not need them really
          Goto WriteLine
        EndIf
        
        
        i=Instr(1,MyLine,"ReDim ")
        If i>0
          MyLine=";"+MyLine;Remark them, coz we cannot handle them really
          Goto WriteLine
        EndIf
        
        
        MyLine=ReplaceString(MyLine,"Public ","",1) ;Uneeded
        MyLine=ReplaceString(MyLine,"Private ","",1);same
        ;  MyLine=Trim(MyLine)
        
        ;Convert structures (Most wanted)
        i=Instr(1,MyLine,"type ")
        If i>0
          Myline="Structure"+Right(MyLine,Len(MyLine)-4) 
          StructureDef=1
        EndIf
        
        i=Instr(1,MyLine,"end type")
        If i>0
          Myline="EndStructure"+Right(MyLine,Len(MyLine)-8) 
          StructureDef=0
        EndIf
        
        ;Special Constant String
        i=Instr(1,MyLine," As String *")
        If i>0
          MyComment.s=""
          t=Instr(i+12,MyLine,";")
          If t>0
            MyComment=Right(MyLine,Len(Myline)-t+1)
            MyLine=Left(Myline,t-1)
          EndIf
          Rest.s=Right(MyLine,Len(myline)-i-12)
          Zahl=Val(Rest)
          If zahl>1
            MyLine=Left(MyLine,i-1)+".b["+Str(Zahl)+"]"
          Else
            MyLine=Left(MyLine,i-1)+".b"
          EndIf
          MyLine=MyLine+MyComment
        EndIf
        
        ;Constants
        MyLine=ReplaceString(MyLine,"Public Const ","#",1)
        MyLine=ReplaceString(MyLine,"Const ","#",1)
        MyLine=ReplaceString(MyLine,"True","#True",1)
        MyLine=ReplaceString(MyLine,"False","#False",1)
        
        ;Keywords these are the changes between VB and Pure
        MyLine=ReplaceString(MyLine,"end if","EndIF",1)
        MyLine=ReplaceString(MyLine,"Sub ","Procedure ",1)
        MyLine=ReplaceString(MyLine,"End Sub","EndProcedure",1)
        MyLine=ReplaceString(MyLine,"Function ","Procedure ",1)
        MyLine=ReplaceString(MyLine,"End Function","EndProcedure",1)
        MyLine=ReplaceString(MyLine,"Select Case","Select",1)
        MyLine=ReplaceString(MyLine,"End Select","EndSelect",1)
        MyLine=ReplaceString(MyLine,"Chr$(","Chr(",1)
        MyLine=ReplaceString(MyLine,"Left$(","Left(",1)
        MyLine=ReplaceString(MyLine,"Right$(","Right(",1)
        MyLine=ReplaceString(MyLine,"Mid$(","Mid(",1)
        
        ;Some unneeded Commands
        MyLine=ReplaceString(MyLine,"Call","",1)
        MyLine=ReplaceString(MyLine,"LSset","",1)
        MyLine=ReplaceString(MyLine,"RSset","",1)
        
        MyLine=ReplaceString(MyLine,"Attribute",";",1)
        MyLine=ReplaceString(MyLine,"Option Explicit",";",1)
        MyLine=ReplaceString(MyLine,"DefInt",";Defint",1)
        MyLine=ReplaceString(MyLine,"on Error",";On Error",1)
        
        
        ;Need more modifications!!
        MyLine=ReplaceString(MyLine,"Instr(","FindString(",1)
        MyLine=ReplaceString(MyLine,"Kill","DeleteFile",1)
        MyLine=ReplaceString(MyLine,"MsgBox","MessageRequester",1)
        
        
        ;  Remove the 'Then'
        i=Instr(1,MyLine,"Then")
        If i>0
          If Trim(Right(MyLine,Len(MyLine)-i-4)) <> "" ;oh there is more than only a then
            MyLine=Left(MyLine,i-1)+":"+Right(MyLine,Len(MyLine)-i-4)+":EndIf"
          Else
            MyLine=Left(MyLine,i-1)
          EndIf
        EndIf
        
        MyLine=ReplaceString(MyLine," &H"," $",1);VB's Hex-notation
        
        MyLine=ReplaceString(MyLine," as long",".l ",1)
        MyLine=ReplaceString(MyLine," as word",".w ",1);Powerbasic specific
        MyLine=ReplaceString(MyLine," as dword",".l ",1);Powerbasic specific
        MyLine=ReplaceString(MyLine," as integer",".w ",1)
        MyLine=ReplaceString(MyLine," as byte",".b ",1)
        MyLine=ReplaceString(MyLine," as single",".f ",1)
        MyLine=ReplaceString(MyLine," as string",".s ",1)   
        MyLine=ReplaceString(MyLine," as boolean",".b ",1)
        If Instr(1,MyLine," as double")>0
          MyLine=ReplaceString(MyLine," as double",".d ",1)
        EndIf                                                ;can be troubleing /2 Bytes missing.
        MyLine=ReplaceString(MyLine," As Any",".l",1)
        
        ;Is a & added at the End of a Number ? If so remove it !
        AgainAND:
        I=Instr(I+1,MyLine,"&")
        If I>1
          If Mid(myLine,I-1,1) <> " "
            MyLine=Left(MyLine,i-1)+Right(MyLine,Len(MyLine)-i)
          EndIf
          Goto AgainAND
        EndIf
        
        
        ;is a structure used ? so convert the Dot to Backslash
        If StructureDef=0 And Instr(1,MyLine,"dim")=0
          againfind:
          i=Instr(1,MyLine,".")
          If i>1
            t=Instr(1,Mid(MyLine,i-1,1),"0123456789 ")
            If t=0
              t=Instr(1,Mid(MyLine,i+1,1),"0123456789 ")
              If t=0
                t=Instr(1,Mid(MyLine,i,3),".b ")
                If t=0
                  t=Instr(1,Mid(MyLine,i,3),".l ")
                  If t=0
                    t=Instr(1,Mid(MyLine,i,3),".w ")
                    If t=0
                      t=Instr(1,Mid(MyLine,i,3),".s ")
                      If t=0
                        t=Instr(1,Mid(MyLine,i,3),".f ")
                        If t=0
                          MyLine=Left(MyLine,i-1)+"\"+Right(MyLine,Len(MyLine)-i)
                          Goto againfind
                        EndIf
                      EndIf
                    EndIf
                  EndIf
                EndIf   
              EndIf
              
            EndIf
          EndIf 
        EndIf
        
        ;Else some unknown Types converting
        MyLine=ReplaceString(MyLine," As ",".",1)
        
        MyLine=ReplaceString(MyLine,"Dim "," ", 1)
        
        ;search if there is any ApiFunction there ?
        If ApiFlag=0
          ResetList(ApisCalls())               ; Reset the list index before the first element.
          While NextElement(ApisCalls())       ; Process all the elements...
            MyLine=ReplaceString(MyLine,ApisCalls()+"(",ApisCalls()+"_(",1)
          Wend
        EndIf
        
        
        
        WriteLine:   
        ;    is there a _ underscore at the End of the line if so merge the lines?
        If Right(MyLine,1)="_"
          OldLine.s=OldLine+" " + MyLine
        Else
          If Trim(Oldline) <> ""
            WriteStringN(2, OldLine+" "+MyLine) ;write down to file
          Else
            WriteStringN(2, MyLine)
          EndIf
          OldLine="" 
        EndIf
      Else
      EndIf
    Until Eof(1)   
    CloseFile(1)
    CloseFile(2)
  EndIf
  PrintN("Ready")
  ; dummy.s=Input()
  CloseConsole()
EndProcedure

SFilename.s=OpenFileRequester("please choose VisualBasic.BAS File", "*.bas","VB module|*.bas", 0)
If SFilename.s <> ""
  i=FindString(SFilename,".bas",1)
  Newname.s=Left(SFilename,i)+"pb"
  DFilename.s=SaveFileRequester("please choose PureBasic.BAS File", NewName,"PB module|*.pb", 0)
  If DFilename <> ""
    VB2PB(SFilename,DFilename)
  EndIf
Else
  MessageRequester("Fault info","FileName missing!",0)
  Beep_(100,500)
EndIf
Its a long way to the top if you wanna .....CodeGuru

Posted: Sun Jun 30, 2002 9:21 pm
by BackupUser
Restored from previous forum. Originally posted by fred.

A such tool can be very useful !

Some comments (at first view) about yout code (don't take offence :):

Use 'DATA' for functions changes, something like:

Data.s "Instr(", "FindString("
Data.s "End If", "EndIf"

etc.. so all the replacement can be done in one For/Next loop, saving lot of typing and making the code more expandable. And you could put all this in an external file .

Now a quick performance tip:

Procedure Instr(Position,O.s,S.s);Find CasesSensitive like VB's
C.s=S:S2.s=LCase(C)
C.s=O:O2.s=LCase(C)
i=FindString(O2,S2,Position)
ProcedureReturn i
EndProcedure

Can be replaced by:

Procedure Instr(Position,O.s,S.s);Find CasesSensitive like VB's
ProcedureRetutn FindString(LCase(O2),LCase(S2),Position)
EndProcedure

Always put string functions inside another when needed, it will suppress unuseful dynamic string allocation. The gain in this change is easely 5-10 times faster.

Fred - AlphaSND
All times are UTC+01:00
Page 1 of 1

Powered by phpBB® Forum Software © phpBB Limited