HOME HOME   SEARCH   CONTACTS 
SSL WebGUI Hosting Powered by WebGUI
THE BEST SITE BUILDER EVER SEEN. AND IT IS FREE! UNBELIEVABLE? YES! HOW? SPONSORED BY OTHER ORGANIZATIONS.

Articles

Site Map


 

ASP2VB6 Convertor

This is an ActiveX source code to convert obsolete ASP website into VB6 source and then compile into P-code or binary:

(C) Copyright Repository: 

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Lib"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True



'THE AULIX ASP2VB6 Convertor
'The AUTHOR of this file is Alexander Borisovich Prokopyev, Kurgan, Russia
'More info can be found at the AUTHOR's website: http://www.aulix.com/resume
'Contact: alexander.prokopyev at aulix dot com
' 
'Copyright (c) Alexander Prokopyev, 2001
' 
'All materials contained in this file are protected by copyright law.
'Nobody except the AUTHOR may alter or remove this copyright notice from copies of the content.
'This is a proprietary software
' 
'The AUTHOR explicitly prohibits to use this content by any method without a prior
'written hand-signed permission of the AUTHOR.



Option Explicit
Option Compare Text
Public SourceVirtDir As String, SourceVBDir As String, TargetDir As String
Public VBClassHeaderFN As String, VBProjectFN As String, ASPFileTemplateFN As String, ASPCommonHeaderFN As String
Public VBProjectName As String
Private FunctionList As Variant, FunctionListRE As Variant, FunctionListLength As Long
Private FSO As New Scripting.FileSystemObject, Lib As Object, ShouldUpdateFunctionNames As Boolean

Function CreateRegExp(ByVal Pattern As String) As VBScript_RegExp_55.RegExp
    Set CreateRegExp = New VBScript_RegExp_55.RegExp
    With CreateRegExp
        .Pattern = Pattern
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
    End With
End Function

Function HTMLFragment2VBCode(ByVal HTMLFragment As String) As String
    HTMLFragment = CreateRegExp("<!--(.|\n)*?-->").Replace(HTMLFragment, "") ' Remove comments and includes
    HTMLFragment = CreateRegExp("^\r\n$").Replace(HTMLFragment, "") ' Remove blank lines
    If HTMLFragment <> "" Then
        If Right(HTMLFragment, 2) = vbNewLine Then 'Remove new line at the end of HTML fragment
            HTMLFragment = Left(HTMLFragment, Len(HTMLFragment) - 2)
        End If
        HTMLFragment = Replace(HTMLFragment, """", """""") 'Make double quotes for VB strings
        HTMLFragment = Replace(HTMLFragment, vbNewLine, """ & vbNewLine " & vbNewLine & "RW """) 'Format new lines
        HTMLFragment2VBCode = "RW """ & HTMLFragment & """"
    End If
End Function

'Splits S into parts interchanging matching values with rests of S string
Function Split2(ByVal S As String, ByVal DelimiterPattern As String) As Variant
    Dim MC As VBScript_RegExp_55.MatchCollection: Set MC = CreateRegExp(DelimiterPattern).Execute(S)
    Dim M As VBScript_RegExp_55.Match
    ReDim A(0 To MC.Count * 2) As String
    Dim I As Long: I = 0
    Dim J As Long: J = 1
    For Each M In MC
        A(I) = Mid(S, J, M.FirstIndex + 1 - J)
        I = I + 1
        A(I) = M.Value
        I = I + 1
        J = M.FirstIndex + 1 + M.Length ' The start of the next fragment
    Next
    A(I) = Mid(S, J)
    Split2 = A
End Function

Function ASPFragment2VBCode(ByVal S As String) As String
    Dim A As Variant: A = Split2(S, "<%(.|\n)*?%>") 'Split into html and <% script %> parts
    Dim I As Long, ScriptFragment As String
    For I = 0 To UBound(A)
        If I Mod 2 = 0 Then 'Create VB code for HTML fragment
            ScriptFragment = HTMLFragment2VBCode(A(I))
        Else 'Create VB code for ASP fragment
            ScriptFragment = Replace(Replace(A(I), "<%", ""), "%>", "")
            If Left(ScriptFragment, 1) = "=" Then ' If it's a <%=xxx%> fragment
                ScriptFragment = "RW " & Mid(ScriptFragment, 2)
            ElseIf Left(ScriptFragment, 2) <> vbNewLine Then
                ScriptFragment = vbNewLine & ScriptFragment
            End If
        End If
        If ScriptFragment <> "" Then
            ASPFragment2VBCode = ASPFragment2VBCode & ScriptFragment & vbNewLine
        End If
    Next
End Function

'Splits S into 2 parts according Pattern, returns them as an array
'First element of the array contains matching parts separated with vbNewLine
'Second part of the array contains the rest of the S
Function ExtractMatchingLines(ByVal Pattern As String, ByVal S As String) As Variant
    Dim A(1) As String, M As VBScript_RegExp_55.Match
    Dim MC As VBScript_RegExp_55.MatchCollection: Set MC = CreateRegExp(Pattern).Execute(S)
    A(0) = ""
    For Each M In MC
        A(0) = A(0) & vbNewLine & M.Value
    Next
    A(1) = CreateRegExp(Pattern).Replace(S, "")
    ExtractMatchingLines = A
End Function

Function ImproveVBCode(ByVal S As String, ByVal ClassName As String) As String
    Const VBStringPattern = """(([^""])|(""""))*"""
    Dim I As Long, J As Long, K As Long
    Dim SUFN As Boolean: SUFN = ShouldUpdateFunctionNames And ClassName <> "Common"
    Dim A2 As Variant, A1 As Variant: A1 = Split(S, vbNewLine) ' Divide by lines
    For I = 0 To UBound(A1)
        A2 = Split2(A1(I), VBStringPattern) 'Split line by VB strings
        A1(I) = ""
        K = 0 ' Position of the comment start
        For J = 0 To UBound(A2) ' Go through lines
            If J Mod 2 = 0 Then ' Go through code without VB strings
                If A2(J) <> "" Then
                    A2(J) = Replace(A2(J), "'#", "") 'Open VB Only code fragments
                    A2(J) = Replace(A2(J), ":", vbNewLine) 'Replace ":" with vbNewLine
                    If SUFN Then
                        A2(J) = UpdateFunctionNames(A2(J))
                    End If
                End If
                K = InStr(1, A2(J), "'") ' Find comment
                If K > 0 Then 'Remove code after comment
                    A1(I) = A1(I) & Mid(A2(J), 1, K - 1)
                    Exit For
                Else 'Use all code
                    A1(I) = A1(I) & A2(J)
                    If J + 1 < UBound(A2) Then
                         A1(I) = A1(I) & A2(J + 1)
                    End If
                End If
            End If
        Next
    Next
    ImproveVBCode = Join(A1, vbNewLine)
End Function

Function ASPFile2VBClasses(ByVal ASPFileName As String) As Variant
    'Read ASP file and convert it to raw VB code
    Dim VBCode As String: VBCode = ASPFragment2VBCode(FSO.OpenTextFile(ASPFileName, ForReading).ReadAll())
    VBCode = Replace(VBCode, "Option Explicit" & vbNewLine, "") 'Remove Option Explicit
    Const ClassPattern = "(^'.*\n)*^class \w+(.|\n)*?^end class" ' Pattern for internal classes
    'Find classes
    Dim MC As VBScript_RegExp_55.MatchCollection: Set MC = CreateRegExp(ClassPattern).Execute(VBCode)
    Dim M As VBScript_RegExp_55.Match, ScriptFragment As String, VBClasses() As String, I As Long: I = 1
    ReDim VBClasses(MC.Count, 1) As String
    'Class wrapper for ASP file
    VBClasses(0, 0) = Lib.GetPureFileName(ASPFileName)
    VBClasses(0, 1) = ImproveVBCode(CreateRegExp(ClassPattern).Replace(VBCode, ""), VBClasses(0, 0))
    'Go through internal classes
    For Each M In MC ' Place classes into separated modules
        ScriptFragment = M.Value
        VBClasses(I, 0) = CreateRegExp("^class (\w+)").Execute(ScriptFragment)(0).SubMatches(0)
        ScriptFragment = CreateRegExp("^class \w+").Replace(ScriptFragment, "")
        ScriptFragment = CreateRegExp("^end class").Replace(ScriptFragment, "")
        VBClasses(I, 1) = ImproveVBCode(ScriptFragment, VBClasses(I, 0))
        I = I + 1
    Next
    'Move code located not in subs or functions to Execute() function
    Dim InFunctionCode As Variant: InFunctionCode = ExtractMatchingLines("(^'.*\n)*((^function \w+(.|\n)*?^end function)|(^sub \w+(.|\n)*?^end sub))", VBClasses(0, 1))
    'Move dim declares outside of Execute() function
    Dim DimPart As Variant: DimPart = ExtractMatchingLines("(dim .+?[\x3A\n])|(const .+?\n)", InFunctionCode(1))
    DimPart(1) = CreateRegExp("^\s*$\r\n").Replace(DimPart(1), "") 'Remove blank lines from Execute() function
    Dim S As String
    If Lib.GetPureFileName(ASPFileName) = "Common" Then
        S = FSO.OpenTextFile(SourceVBDir & "\" & ASPCommonHeaderFN).ReadAll()
    Else
        S = "Dim CLib As New Common" & vbNewLine & "Public Function Execute()" & vbNewLine & "    CLib.Execute"
    End If
    VBClasses(0, 1) = DimPart(0) & vbNewLine & S & vbNewLine & DimPart(1) & vbNewLine & "End Function" & InFunctionCode(0)
    'Result
    ASPFile2VBClasses = VBClasses
End Function


Function ConvertASPVirtDir2VBDir()
    'Copy other required files
    With CreateObject("SysUtils.Lib")
        '.Cmd "copy " & SourceVBDir & "\*.cls " & TargetDir
        .cmd "xcopy /e /y " & SourceVirtDir & "  " & TargetDir, False
        .cmd "del " & TargetDir & "\*.asp", False
        .cmd "del " & TargetDir & "\*.inc", False
    End With
    Dim VBClassHeader As String: VBClassHeader = FSO.OpenTextFile(SourceVBDir & "\" & VBClassHeaderFN, ForReading).ReadAll()
    Dim ASPFileTemplate As String: ASPFileTemplate = FSO.OpenTextFile(SourceVBDir & "\" & ASPFileTemplateFN, ForReading).ReadAll()
    Dim Fld As Scripting.Folder: Set Fld = FSO.GetFolder(SourceVirtDir)
    Dim F As Scripting.File, TS As Scripting.TextStream, S As String
    Dim ClassName As String, ClassList As String, ClassInfo As Variant, I As Long, J As Long
    'Prepare the list of names of functions and subs
    ShouldUpdateFunctionNames = False
    FunctionList = CreateFunctionList(ASPFile2VBClasses(SourceVirtDir & "\" & "Common.asp")(0, 1))
    ShouldUpdateFunctionNames = True
    Dim L As Long: L = UBound(FunctionList)
    ReDim Preserve FunctionList(L + 8)
    FunctionList(L + 1) = "Con"
    FunctionList(L + 2) = "Lib"
    FunctionList(L + 3) = "Server"
    FunctionList(L + 4) = "Application"
    FunctionList(L + 5) = "Session"
    FunctionList(L + 6) = "Request"
    FunctionList(L + 7) = "Response"
    FunctionList(L + 8) = "KLib"
    CreateFunctionListRE
    For Each F In Fld.Files ' Go through all the ASP files in the virtual directory
        If Lib.GetFileExt(F.Name) = "asp" And F.Name <> "ProjectSpecific.asp" Then
            ClassInfo = ASPFile2VBClasses(F.Path) ' Split raw VB code by classes
            For I = 0 To UBound(ClassInfo) ' Create *.cls files
                'If I = 0 And F.Path = ASPCommonFilePath Then ' Remove "CLib." prefixes from Common.cls file
                'ClassInfo(I, 1) = CreateRegExp("(^|[^\w\.])CLib\.").Replace(ClassInfo(I, 1), "$1")
                'End If
                If I = 0 Then 'File number
                    J = J + 1 'Class number
                    If ClassInfo(I, 0) = "Common" Then
                        ClassName = ClassInfo(I, 0)
                    Else
                        ClassName = "Class" & Lib.PadL(J, "0", 3)
                    End If
                    'Create wrapper page
                    Set TS = FSO.OpenTextFile(TargetDir & "\" & ClassInfo(0, 0) & ".asp", ForWriting, True)
                    S = Replace(ASPFileTemplate, "VBProjectName", VBProjectName)
                    TS.Write Replace(S, "ClassName", ClassName)
                Else
                    ClassName = ClassInfo(I, 0)
                End If
                ClassList = ClassList & "Class=" & ClassName & "; " & ClassInfo(I, 0) & ".cls" & vbNewLine
                Set TS = FSO.OpenTextFile(TargetDir & "\" & ClassInfo(I, 0) & ".cls", ForWriting, True)
                TS.Write Replace(VBClassHeader, "_VB_Name_", ClassName) & ClassInfo(I, 1)
            Next
        End If
    Next
    ClassList = ClassList & "Class=Lib; Lib.cls" & vbNewLine & "Class=GlobalASA; GlobalASA.cls" & vbNewLine
    'Create VB Project files
    S = FSO.OpenTextFile(TargetDir & "\" & VBProjectFN, ForReading).ReadAll()
    'S = Lib.CreateRegExp("Type=OleDll\r\n(Class=.+\n)+").Replace(S, "Type=OleDll" & vbNewLine & ClassList)
    S = Lib.CreateRegExp("(Class=.+\n)+").Replace(S, ClassList)
    FSO.OpenTextFile(TargetDir & "\" & VBProjectFN, ForWriting, True).Write S
    With CreateObject("SysUtils.Lib")
        .cmd "screnc /e asp /l vbscript " & TargetDir & "\*.asp " & TargetDir & "\Encoded", False
        .cmd "screnc /xl /e asp /l vbscript " & TargetDir & "\*.asa " & TargetDir & "\Encoded", False
    End With
End Function

Function CreateFunctionList(ByVal S As String) As Variant
    Dim MC As VBScript_RegExp_55.MatchCollection: Set MC = CreateRegExp("(^\s*?function\s*?(\w+?)\s*?\()|(^\s*?sub\s*?(\w+?)\s*?\()").Execute(S)
    Dim M As VBScript_RegExp_55.Match, I As Long: I = 0
    ReDim A(0 To MC.Count - 1)
    For Each M In MC
        If IsEmpty(M.SubMatches(1)) Then
            A(I) = M.SubMatches(3)
        Else
            A(I) = M.SubMatches(1)
        End If
        'Debug.Print A(I)
        I = I + 1
    Next
    CreateFunctionList = A
End Function

Sub CreateFunctionListRE()
    Dim I As Long
    FunctionListLength = UBound(FunctionList)
    ReDim FunctionListRE(0 To FunctionListLength) As VBScript_RegExp_55.RegExp
    For I = 0 To FunctionListLength
        Set FunctionListRE(I) = CreateRegExp("(^|[^\w\.])" & FunctionList(I) & "(\b|$)")
    Next
End Sub

Function UpdateFunctionNames(ByVal S As String) As String
    Dim I As Long, L As Long: L = UBound(FunctionList)
    For I = 0 To L
        S = FunctionListRE(I).Replace(S, "$1CLib." & FunctionList(I))
    Next
    UpdateFunctionNames = S
End Function

Private Sub Class_Initialize()
    Set Lib = CreateObject("Common1.Lib")
End Sub

(C) Aulix.com, 2005-2024


If you like the page - tweet and share it. Если статья понравилась - лайкайте,твитьте, делитесь.