via.cls

VB写的一个IDE开发环境,支持脚本运行,内置了一个简单的编译器,可以直接生成EXE.. 推荐下载!

        ReDim Preserve Imports(UBound(Imports) + NumberOfItems) As TYPE_IMPORT
        For i = 1 To NumberOfItems
            Get #FileNum, , Imports(UBound(Imports) - NumberOfItems + i)
            Imports(UBound(Imports) - NumberOfItems + i).Used = False
        Next i
        Get #FileNum, , NumberOfItems
        ReDim Preserve Types(UBound(Types) + NumberOfItems) As TYPE_TYPE
        For i = 1 To NumberOfItems
            Get #FileNum, , Types(UBound(Types) - NumberOfItems + i)
        Next i
        Get #FileNum, , NumberOfItems
        ReDim Preserve Constants(UBound(Constants) + NumberOfItems) As TYPE_CONSTANT
        For i = 1 To NumberOfItems
            Get #FileNum, , Constants(UBound(Constants) - NumberOfItems + i)
        Next i
    Close #FileNum
    If IsSymbol(",") Then Symbol ",": ImportLibrary: Exit Sub
    Terminator
    CodeBlock
    Exit Sub
InvalidLibrary:
    ErrMessage "Invalid Library Format => " & Ident
    Close #FileNum
End Sub
Sub ExportLibrary(sFile As String)
    Dim i As Long
    Dim FileNum As Long
    Dim sFileName As String
    If sFile = "" Then ErrMessage "File is not saved => cannot build library.": Exit Sub
    InfMessage "Building Library.."
    FileNum = FreeFile
    sFileName = sFile
    sFileName = Left(sFileName, Len(sFileName) - 4)
    sFileName = sFileName & ".lib"
    If Dir(sFileName) <> "" Then Kill sFileName
    Open sFileName For Binary As #FileNum
        Put #FileNum, , UBound(Imports)
            For i = 1 To UBound(Imports): Put #FileNum, , Imports(i): Next i
        Put #FileNum, , UBound(Types)
            For i = 1 To UBound(Types): Put #FileNum, , Types(i): Next i
        Put #FileNum, , UBound(Constants)
            For i = 1 To UBound(Constants): Put #FileNum, , Constants(i): Next i
    Close #FileNum
    InfMessage "library compiled. => " & sFileName
    WriteSummary Summary
End Sub





Sub InitLinker(sFile As String)
    GenerateResources sFile
    GenerateImportTable
    GenerateExportTable
    If IsDLL Then WriteRelocations
    OutputDOSHeader
    OutputDOSStub
    OutputPEHeader
    OutputSectionTable
    OutputSections
End Sub
Sub InitSections()
    ReDim Section(0) As TYPE_SECTION
    ReDim Section(0).Bytes(0)
    Section(0).Name = ".link"
    Section(UBound(Section)).SectionType = 0
    Section(UBound(Section)).Characteristics = 0
End Sub
Sub Link(sFile As String, Run As Boolean)
    Dim i As Double
    On Error GoTo LinkFail
    If IsDLL Then sFile = Left(sFile, Len(sFile) - 3): sFile = sFile & "DLL"
    If Dir(sFile) <> "" Then Kill sFile
    Open sFile For Binary As #1
        For i = 1 To UBound(Section(0).Bytes)
            Put #1, , Section(0).Bytes(i)
        Next i
    Close #1
    If IsDLL Then
        InfMessage "动态连接库编译完毕. 用时:" & vbCrLf & EndCounter & " 秒. 文件大小:" & UBound(Section(0).Bytes) & " 字节."
    Else
        InfMessage "程序编译完毕. 用时:" & vbCrLf & EndCounter & " 秒. 文件大小:" & UBound(Section(0).Bytes) & " 字节."
    End If
    If Run = True Then sFileToRun = sFile
    WriteSummary Summary
    Exit Sub
LinkFail:
    ErrMessage "连接进程失败 -> 进程已经运行.": WriteSummary Summary
    Close #1
End Sub
Sub OutputDOSHeader()
    OutputDWord &H805A4D
    OutputDWord &H1
    OutputDWord &H100004
    OutputDWord &HFFFF
    OutputDWord &H140
    OutputDWord &H0
    OutputDWord &H40
    OutputDWord &H0
    OutputDWord &H0
    OutputDWord &H0
    OutputDWord &H0
    OutputDWord &H0
    OutputDWord &H0
    OutputDWord &H0
    OutputDWord &H0
    OutputDWord &H80
End Sub
Sub OutputDOSStub()
    OutputDWord &HEBA1F0E
    OutputDWord &HCD09B400
    OutputDWord &H4C01B821
    OutputDWord &H687421CD
    OutputDWord &H70207369
    OutputDWord &H72676F72
    OutputDWord &H63206D61
    OutputDWord &H6F6E6E61
    OutputDWord &H65622074
    OutputDWord &H6E757220
    OutputDWord &H206E6920
    OutputDWord &H20534F44
    OutputDWord &H65646F6D
    OutputDWord &H240A0D2E
    OutputDWord &H0
    OutputDWord &H0
End Sub
Sub OutputPEHeader()
    OutputDWord &H4550
    OutputWord &H14C
    OutputWord NumberOfSections
    OutputDWord &H0
    OutputDWord &H0
    OutputDWord &H0
    OutputWord &HE0
    If IsDLL Then
        OutputWord &H210E
    Else
        OutputWord &H818F
    End If
    OutputWord &H10B
    OutputByte &H5
    OutputByte &H0
    DeclareAttribute "SizeOfCode"
    DeclareAttribute "SizeOfInitializedData"
    DeclareAttribute "SizeOfUnInitializedData"
    DeclareAttribute "AddressOfEntryPoint"
    DeclareAttribute "BaseOfCode"
    DeclareAttribute "BaseOfData"
    OutputDWord &H400000
    OutputDWord &H1000
    OutputDWord &H200
    OutputWord &H1
    OutputWord &H0
    OutputWord &H0
    OutputWord &H0
    OutputWord &H4
    OutputWord &H0
    OutputDWord &H0
    DeclareAttribute "SizeOfImage"
    DeclareAttribute "SizeOfHeaders"
    OutputDWord &H0
    OutputWord CInt(AppType)
    OutputWord &H0
    OutputDWord &H10000
    OutputDWord &H10000
    OutputDWord &H10000
    OutputDWord &H0
    OutputDWord &H0
    OutputDWord &H10
    DeclareAttribute "ExportTable.Entry"
    DeclareAttribute "ExportTable.Size"
    DeclareAttribute "ImportTable.Entry"
    DeclareAttribute "ImportTable.Size"
    DeclareAttribute "ResourceTable.Entry"
    DeclareAttribute "ResourceTable.Size"
    OutputDWord &H0: OutputDWord &H0
    OutputDWord &H0: OutputDWord &H0
    DeclareAttribute "RelocationTable.Entry"
    DeclareAttribute "RelocationTable.Size"
    OutputDWord &H0: OutputDWord &H0
    OutputDWord &H0: OutputDWord &H0
    OutputDWord &H0: OutputDWord &H0
    OutputDWord &H0: OutputDWord &H0
    OutputDWord &H0: OutputDWord &H0
    OutputDWord &H0: OutputDWord &H0
    OutputDWord &H0: OutputDWord &H0
    OutputDWord &H0: OutputDWord &H0
    OutputDWord &H0: OutputDWord &H0
    OutputDWord &H0: OutputDWord &H0
End Sub
Sub OutputSectionTable()
    Dim i As Integer
    Dim ni As Integer
    For i = 1 To UBound(Section)
        If UBound(Section(i).Bytes) = 0 Then GoTo SkipSectionST
        For ni = 1 To 8
            If ni > Len(Section(i).Name) Then
                OutputByte &H0
            Else
                OutputByte Asc(Mid$(Section(i).Name, ni, 1))
            End If
        Next ni
        DeclareAttribute Section(i).Name & ".VirtualSize"
        DeclareAttribute Section(i).Name & ".VirtualAddress"
        DeclareAttribute Section(i).Name & ".SizeOfRawData"
        DeclareAttribute Section(i).Name & ".PointerToRawData"
        DeclareAttribute Section(i).Name & ".PointerToRelocations"
        OutputDWord &H0
        OutputWord &H0
        OutputWord &H0
        OutputDWord Section(i).Characteristics
SkipSectionST:
    Next i
    Dim ii As Integer: Dim HowBig As Integer
    SizeOfHeader = UBound(Section(0).Bytes)
    For ii = 0 To SizeOfHeader + 512 Step 512
        HowBig = ii
    Next ii
    For ii = SizeOfHeader To HowBig - 1
        AddSectionNameByte ".link", &H0
    Next ii
    SizeOfHeader = UBound(Section(0).Bytes)
    FixAttribute "SizeOfHeaders", CLng(SizeOfHeader)
    SizeOfAllSectionsBeforeRaw = SizeOfHeader
End Sub
Sub FixTableEntry(SectionID As Integer)
    Select Case Section(SectionID).SectionType
        Case Code: FixAttribute "AddressOfEntryPoint", SizeOfAllSectionsBefore
        Case Import: FixAttribute "ImportTable.Entry", SizeOfAllSectionsBefore
        Case Export: FixAttribute "ExportTable.Entry", SizeOfAllSectionsBefore
        Case Resource: FixAttribute "ResourceTable.Entry", SizeOfAllSectionsBefore
        Case Relocate: FixAttribute "RelocationTable.Entry", SizeOfAllSectionsBefore
    End Select
End Sub
Sub FixTableSize(SectionID As Integer, Size As Long)
    Select Case Section(SectionID).SectionType
        Case Import: FixAttribute "ImportTable.Size", Size
        Case Export: FixAttribute "ExportTable.Size", Size
        Case Resource: FixAttribute "ResourceTable.Size", Size
        Case Relocate: FixAttribute "RelocationTable.Size", Size
    End Select
End Sub
Sub OutputSections()
    Dim i As Integer
    Dim ii As Long
    Dim PhysicalSize As Long
    SizeOfAllSectionsBefore = &H1000
    For i = 1 To UBound(Section)
        If UBound(Section(i).Bytes) = 0 Then GoTo SkipSectionOS
        FixAttribute Section(i).Name & ".VirtualSize", UBound(Section(i).Bytes)
        FixTableSize i, UBound(Section(i).Bytes)
        PhysicalSize = PhysicalSizeOf(Section(i).Bytes)
        For ii = UBound(Section(i).Bytes) To PhysicalSize - 1
            AddSectionNameByte Section(i).Name, &H0
        Next ii
        FixTableEntry i
        If Section(i).Name = ".reloc" Then FixAttribute ".code.PointerToRelocations", SizeOfAllSectionsBefore
        FixAttribute Section(i).Name & ".VirtualAddress", SizeOfAllSectionsBefore
        SizeOfAllSectionsBefore = SizeOfAllSectionsBefore + VirtualSizeOf(Section(i).Bytes)
        FixAttribute Section(i).Name & ".PointerToRawData", SizeOfAllSectionsBeforeRaw
        SizeOfAllSectionsBeforeRaw = SizeOfAllSectionsBeforeRaw + PhysicalSize
        FixAttribute Section(i).Name & ".SizeOfRawData", PhysicalSize
        For ii = 1 To UBound(Section(i).Bytes)
            AddSectionNameByte ".link", Section(i).Bytes(ii)
        Next ii
        For ii = 0 To &H1000& * &HFFFF& Step &H1000
            If PhysicalSize = ii Then SizeOfAllSectionsBefore = SizeOfAllSectionsBefore - &H1000
        Next ii
SkipSectionOS:
    Next i
    FixAttribute "SizeOfImage", SizeOfAllSectionsBefore
End Sub
Function PhysicalSizeOf(Value() As Byte, Optional ExtraSub As Long) As Long
    Dim i As Long
    If UBound(Value) = 0 Then PhysicalSizeOf = 0: Exit Function
    For i = 0 To UBound(Value) + 512 - ExtraSub Step 512
        PhysicalSizeOf = i
    Next i
End Function
Function VirtualSizeOf(Value() As Byte, Optional ExtraSub As Long) As Long
    Dim i As Long
    If UBound(Value) = 0 Then
        VirtualSizeOf = 0
    Else
        For i = &H1000 To &H1000& * &HFFFF& Step &H1000
            If i > (UBound(Value) - ExtraSub) Then
                VirtualSizeOf = i
                Exit For
            End If
        Next i
    End If
End Function
Sub DeclareAttribute(Name As String)
    AddSymbol Name, UBound(Section(0).Bytes), Linker
    OutputDWord &H0
End Sub
Sub FixAttribute(Name As String, Value As Long)
    FixDWord GetSymbolOffset(Name), CLng(Value)
End Sub
Function OffsetOf(Name As String) As Long
    Dim i As Byte
    For i = 1 To UBound(Section)
        If Section(i).Name = Name Then
            OffsetOf = UBound(Section(i).Bytes): Exit Function
        End If
    Next i
End Function
Function FixDWord(Offset As Long, Value As Long)
    Section(0).Bytes(Offset + 1) = LoByte(LoWord(Value))
    Section(0).Bytes(Offset + 2) = HiByte(LoWord(Value))
    Section(0).Bytes(Offset + 3) = LoByte(HiWord(Value))
    Section(0).Bytes(Offset + 4) = HiByte(HiWord(Value))
End Function
Function NumberOfSections() As Integer
    Dim i As Byte
    For i = 1 To UBound(Section)
        If UBound(Section(i).Bytes) > 0 Then
            NumberOfSections = NumberOfSections + 1
        End If
    Next i
End Function
Function SectionExists(Name As String) As Boolean
    Dim i As Byte
    For i = 1 To UBound(Section)
        If Section(i).Name = Name Then
            SectionExists = True: Exit Function
        End If
    Next i
End Function
Function SectionID(Name As String) As Byte
    Dim i As Byte
    For i = 1 To UBound(Section)
        If Section(i).Name = Name Then
            SectionID = i: Exit Function
        End If
    Next i
End Function
Sub OutputByte(Value As Byte)
    AddSectionNameByte ".link", Value
End Sub
Sub OutputWord(Value As Integer)
    AddSectionNameWord ".link", Value
End Sub
Sub OutputDWord(Value As Long)
    AddSectionNameDWord ".link", Value
End Sub
Sub AddSectionByte(Value As Byte)
    Dim lID As Integer
    lID = GetSectionIDByName(CurrentSection)
    ReDim Preserve Section(lID).Bytes(UBound(Section(lID).Bytes) + 1) As Byte
    Section(lID).Bytes(UBound(Section(lID).Bytes)) = Value
End Sub
Sub AddSectionWord(Value As Integer)
    AddSectionByte LoByte(Value)
    AddSectionByte HiByte(Value)
End Sub
Sub AddSectionDWord(Value As Long)
    AddSectionWord LoWord(Value)
    AddSectionWord HiWord(Value)
End Sub
Sub AddSectionNameByte(Name As String, Value As Byte)
    Dim lID As Integer
    lID = GetSectionIDByName(Name)
    ReDim Preserve Section(lID).Bytes(UBound(Section(lID).Bytes) + 1) As Byte
    Section(lID).Bytes(UBound(Section(lID).Bytes)) = Value
End Sub
Sub AddSectionNameWord(Name As String, Value As Integer)
    AddSectionNameByte Name, LoByte(Value)
    AddSectionNameByte Name, HiByte(Value)
End Sub
Sub AddSectionNameDWord(Name As String, Value As Long)
    AddSectionNameWord Name, LoWord(Value)
    AddSectionNameWord Name, HiWord(Value)
End Sub
Sub AddSectionNameSingle(Name As String, Value As Single)
    Dim B1 As Byte: Dim B2 As Byte
    Dim B3 As Byte: Dim B4 As Byte
    Open App.Path & "\single.dmp" For Binary As #1
        Put #1, 1, Value
        Get #1, 1, B4: Get #1, 2, B3
        Get #1, 3, B2: Get #1, 4, B1
    Close #1
    AddSectionNameByte Name, B4: AddSectionNameByte Name, B3
    AddSectionNameByte Name, B2: AddSectionNameByte Name, B1
    Kill App.Path & "\single.dmp"
End Sub
Function GetSectionIDByName(Name As String) As Long
    Dim i As Byte
    For i = 0 To UBound(Section)
        If Section(i).Name = Name Then
            GetSectionIDByName = i
            Exit Function
        End If
    Next i
    ErrMessage "内容 "
End Function