via.cls

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

    AddFixup "NAMES_TABLE", OffsetOf(".edata"), Export
    AddSectionDWord 0
    AddFixup "ORDINAL_TABLE", OffsetOf(".edata"), Export
    AddSectionDWord 0
    AddSymbol "ADDRESSES_TABLE", OffsetOf(".edata"), Export, ST_EXPORT
    For i = 1 To UBound(Exports)
        AddFixup Exports(i).Name & ".Address", OffsetOf(".edata"), Export
        AddSectionDWord 0
    Next i
    AddSymbol "NAMES_TABLE", OffsetOf(".edata"), Export, ST_EXPORT
    For i = 1 To UBound(Exports)
        AddFixup "_" & Exports(i).Name, OffsetOf(".edata"), Export
        AddSectionDWord 0
    Next i
    AddSymbol "ORDINAL_TABLE", OffsetOf(".edata"), Export, ST_EXPORT
    For i = 1 To UBound(Exports)
        AddSectionWord Exports(i).Ordinal - 1
    Next i
    AddSymbol "DLL_NAME", OffsetOf(".edata"), Export, ST_EXPORT
    For ii = 1 To Len(NameDLL)
        AddSectionByte CByte(Asc(Mid$(UCase(NameDLL), ii, 1)))
    Next ii
    AddSectionByte 0
    For i = 1 To UBound(Exports)
        AddSymbol "_" & Exports(i).Name, OffsetOf(".edata"), Export, ST_EXPORT
        For ii = 1 To Len(Exports(i).Name)
            AddSectionByte CByte(Asc(Mid$(Exports(i).Name, ii, 1)))
        Next ii
        AddSectionByte 0
    Next i
End Sub
Sub Expression(Optional AssignTo As String)
    SkipBlank
    Assignment = AssignTo
    EvaluateCount = 0
    IsFloat = False
    Call EvalRelation
    If Not AssignTo = "" Then
        If AssignTo = "$Intern.Compare.One" And CompareOne <> "" Then Exit Sub
        If AssignTo = "$Intern.Compare.Two" And CompareTwo <> "" Then Exit Sub
        If GetSymbolSize(AssignTo) = 1 Then
            PopEDX
            AddCodeWord &H1588
            AddFixup AssignTo, OffsetOf(".code"), Code, &H400000
            AddCodeDWord 0
        ElseIf GetSymbolSize(AssignTo) = 2 Then
            PopEDX
            AddCodeWord &H8966
            AddCodeByte &H15
            AddFixup AssignTo, OffsetOf(".code"), Code, &H400000
            AddCodeDWord 0
        Else
            PopEAX
            AssignEAX AssignTo
        End If
    End If
End Sub
Sub InitFixups()
    ReDim Fixups(0) As TYPE_FIXUP
End Sub
Sub AddCodeFixup(Name As String)
    AddFixup Name, OffsetOf(".code"), Code, &H400000
    AddCodeDWord 0
End Sub
Sub DeleteFixup(Name As String)
    Dim i As Long
    For i = 0 To UBound(Fixups)
        If Fixups(i).Name = Name Then
            Fixups(i).Deleted = True
            Exit Sub
        End If
    Next i
End Sub
Sub AddFixup(Name As String, Offset As Long, Section As ENUM_SECTION_TYPE, Optional ExtraAdd As Long)
    ReDim Preserve Fixups(UBound(Fixups) + 1) As TYPE_FIXUP
    Fixups(UBound(Fixups)).Name = Name
    Fixups(UBound(Fixups)).Offset = Offset
    Fixups(UBound(Fixups)).Section = Section
    Fixups(UBound(Fixups)).ExtraAdd = ExtraAdd
End Sub
Function LinkerFix(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 PhysicalAddressOf(EST As ENUM_SECTION_TYPE) As Long
    Dim i As Byte
    PhysicalAddressOf = SizeOfHeader
    For i = 1 To UBound(Section)
        If Section(i).SectionType = EST Then Exit Function
        PhysicalAddressOf = PhysicalAddressOf + PhysicalSizeOf(Section(i).Bytes, 1)
    Next i
End Function
Function VirtualAddressOf(EST As ENUM_SECTION_TYPE) As Long
    Dim i As Byte
    VirtualAddressOf = &H1000
    For i = 1 To UBound(Section)
        If Section(i).SectionType = EST Then Exit Function
        VirtualAddressOf = VirtualAddressOf + VirtualSizeOf(Section(i).Bytes, 1)
    Next i
End Function
Sub DoFixups()
    Dim i As Integer: Dim ii As Integer: Dim Found As Boolean
    For i = 1 To UBound(Fixups)
        If Fixups(i).Deleted = True Then GoTo SkipFixup
        For ii = 1 To UBound(Symbols)
            If Symbols(ii).IsProto Then GoTo SkipSymbol
            If Fixups(i).Name = Symbols(ii).Name Then
                If Symbols(ii).SymType = ST_LABEL Or Symbols(ii).SymType = ST_LOCAL_DWORD Or Symbols(ii).SymType = ST_LOCAL_SINGLE Or Symbols(ii).SymType = ST_LOCAL_STRING Or Symbols(ii).SymType = ST_FRAME Then
                    LinkerFix PhysicalAddressOf(Fixups(i).Section) + Fixups(i).Offset, Symbols(ii).Offset - Fixups(i).Offset - 4 + Fixups(i).ExtraAdd
                Else
                    LinkerFix PhysicalAddressOf(Fixups(i).Section) + Fixups(i).Offset, VirtualAddressOf(Symbols(ii).Section) + Symbols(ii).Offset + Fixups(i).ExtraAdd
                End If
                Found = True
                GoTo FixupFound
            End If
SkipSymbol:
        Next ii
FixupFound:
        If Found = False Then
            If InStr(1, Fixups(i).Name, ".HeapHandle", vbTextCompare) Then
                ErrMessage ""
            ElseIf InStr(1, Fixups(i).Name, ".PtrToArray", vbTextCompare) Then
                ErrMessage ""
            ElseIf InStr(1, Fixups(i).Name, "AddressToString", vbTextCompare) Then
                ErrMessage "cannot compare string with value": Exit Sub
            Else
                ErrMessage "symbol "
            End If
        End If
        Found = False
        If Not IsCmdCompile Then 编译进程 = "Fixups.. (" & CInt(i / UBound(Fixups) * 100) & "% done..)"
SkipFixup:
    Next i
End Sub

Sub InitFrames()
    fcUniqueID = 0
    ReDim Frames(0) As TYPE_FRAME
End Sub
Sub AddFrameDeclare(VarName As String)
    Frames(UBound(Frames)).Declares = Frames(UBound(Frames)).Declares & VarName & ","
End Sub
Sub AddFrame(Name As String, Optional IsProperty As Boolean)
    ReDim Preserve Frames(UBound(Frames) + 1) As TYPE_FRAME
    Frames(UBound(Frames)).Name = Name
    Frames(UBound(Frames)).Property = IsProperty
    CurrentFrame = Name
End Sub
Function IsLocalVariable(Ident As String) As Boolean
    Dim i As Integer
    For i = 1 To UBound(Symbols)
        If Symbols(i).Name = CurrentFrame & "." & Ident Then
            IsLocalVariable = True
            Exit Function
        End If
    Next i
End Function
Function GetFrameIDByName(Name As String) As Long
    Dim i As Integer
    For i = 1 To UBound(Frames)
        If Frames(i).Name = Name Then
            GetFrameIDByName = i
            Exit Function
        End If
    Next i
End Function
Function GetReturnType(Name As String)
    Dim i As Integer
    For i = 1 To UBound(Frames)
        If Frames(i).Name = Name Then
            GetReturnType = Frames(i).ReturnAs
            Exit Function
        End If
    Next i
End Function
Sub CallFrame(Ident As String, Optional FromExpression As Boolean)
    Dim i As Integer
    Dim fID As Long
    Dim iLabel As Long
    Dim FrameDeclares As Variant
    IsCallFrame = True
    fID = GetFrameIDByName(Ident)
    FrameDeclares = Split(Frames(fID).Declares, ",")
    ReverseParams
    Symbol "("
    For i = UBound(FrameDeclares) - 1 To 0 Step -1
        If GetSymbolType(Frames(fID).Name & "." & FrameDeclares(i)) = ST_LOCAL_DWORD Or GetSymbolType(Frames(fID).Name & "." & FrameDeclares(i)) = ST_LOCAL_SINGLE Then
            Expression
        ElseIf GetSymbolType(Frames(fID).Name & "." & FrameDeclares(i)) = ST_LOCAL_STRING Then
            Expression
        Else
            Expression Frames(fID).Name & "." & FrameDeclares(i)
            PushContent Frames(fID).Name & "." & FrameDeclares(i)
        End If
        If IsSymbol(",") Then Position = Position + 1
    Next i
    Symbol ")"
    IsCallFrame = False
    If Not FromExpression Then Terminator
    ExprCall Ident
    If Not FromExpression Then CodeBlock
End Sub
Sub CallProperty(Ident As String, Optional FromExpression As Boolean)
    Dim i As Integer
    Dim fID As Long
    Dim iLabel As Long
    Dim FrameDeclares As Variant
    IsCallFrame = True
    SkipBlank
    If Not FromExpression Then
        Symbol "="
        Expression "$Intern.Property"
        PushContent "$Intern.Property"
        Terminator
    End If
    IsCallFrame = False
    If CurrentFrame <> Ident Then
        ExprCall Ident
    End If
    If Not FromExpression Then CodeBlock
End Sub
Function IsFrame(Name As String) As Boolean
    Dim i As Integer
    For i = 1 To UBound(Frames)
        If Frames(i).Name = Name Then
            IsFrame = True
            Exit Function
        End If
    Next i
End Function
Function IsProperty(Name As String) As Boolean
    Dim i As Integer
    For i = 1 To UBound(Frames)
        If Frames(i).Name = Name Then
            If Frames(i).Property Then
                IsProperty = True
                Exit Function
            End If
        End If
    Next i
End Function
Sub StatementReturn()
    Symbol "("
    Expression "$Intern.Return"
    PushContent "$Intern.Return"
    ExprJump CurrentFrame & ".end"
    Symbol ")"
    Terminator
    CodeBlock
End Sub

Sub Align4(SectionName As String)
    Dim i As Long
    If OffsetOf(SectionName) = Int(OffsetOf(SectionName) / 4) * 4 Then Exit Sub
    For i = OffsetOf(SectionName) To Int((OffsetOf(SectionName) / 4) + 1) * 4 - 1
        AddSectionNameByte SectionName, 0
    Next i
End Sub


Sub InitImports()
    ReDim Imports(0) As TYPE_IMPORT
End Sub
Function IsImportUsed(AliasID As Long) As Boolean
    If Imports(AliasID).Used = True Then
        IsImportUsed = True
    Else
        IsImportUsed = False
    End If
End Function
Function ImportExists(Name As String) As Boolean
    Dim i As Long
    For i = 0 To UBound(Imports)
        If Imports(i).Name = Name Then
            ImportExists = True
            Exit Function
        End If
    Next i
End Function
Sub AddImport(Name As String, Library As String, pCount As Long, Optional Alias As String, Optional Used As Boolean = False)
    If ImportExists(Name) Then Exit Sub
    ReDim Preserve Imports(UBound(Imports) + 1) As TYPE_IMPORT
    Imports(UBound(Imports)).Name = Name
    Imports(UBound(Imports)).pCount = pCount
    Imports(UBound(Imports)).Library = Library
    Imports(UBound(Imports)).Used = Used
    If Alias <> "" Then
        Imports(UBound(Imports)).Alias = Alias
    Else
        Imports(UBound(Imports)).Alias = Name
    End If
End Sub
Function SetImportUsed(Name As String, Offset As Long)
    Dim i As Long
    For i = 1 To UBound(Imports)
        If Imports(i).Alias = Name Then
            Imports(i).Used = True
            AddRelocation Offset
            Exit Function
        End If
    Next i
End Function
Function ImportPCountByName(Name As String) As Long
    Dim i As Long
    For i = 1 To UBound(Imports)
        If Imports(i).Alias = Name Then
            ImportPCountByName = Imports(i).pCount
            Exit Function
        End If
    Next i
End Function
Function IsImport(Ident As String) As Boolean
    Dim i As Long
    For i = 1 To UBound(Imports)
        If Imports(i).Alias = Ident Then
            IsImport = True
            Exit Function
        End If
    Next i
End Function
Sub GenerateImportTable(Optional NoSymbols As Boolean)
    Dim i As Long: Dim ii As Long: Dim Duplicate As Boolean: Dim Libraries() As String
    CurrentSection = ".idata"
    ReDim Libraries(0) As String
    If UBound(Imports) = 0 Then Exit Sub
    For i = 1 To UBound(Imports)
        While Not IsImportUsed(i)
            i = i + 1
            If i > UBound(Imports) Then Exit For
        Wend
        For ii = 1 To UBound(Libraries)
            If UCase(Libraries(ii)) = UCase(Imports(i).Library) Then
                Duplicate = True
            End If
        Next ii
        If Duplicate = False Then
            ReDim Preserve Libraries(UBound(Libraries) + 1) As String
            Libraries(UBound(Libraries)) = UCase(Imports(i).Library)
        End If
        Duplicate = False
    Next i
    For i = 1 To UBound(Libraries)
        AddSectionDWord &H0
        AddSectionDWord &H0
        AddSectionDWord &H0
        AddFixup Libraries(i) & "_NAME", OffsetOf(".idata"), Import
        AddSectionDWord &H0
        AddFixup Libraries(i) & "_TABLE", OffsetOf(".idata"), Import
        AddSectionDWord &H0
    Next i
    If UBound(Libraries) > 0 Then
        AddSectionDWord &H0
        AddSectionDWord &H0
        AddSectionDWord &H0
        AddSectionDWord &H0
        AddSectionDWord &H0
    End If
    For i = 1 To UBound(Libraries)
        AddSymbol Libraries(i) & "_TABLE", OffsetOf(".idata"), Import
        For ii = 1 To UBound(Imports)
            If UCase(Imports(ii).Library) = UCase(Libraries(i)) Then
                If Imports(ii).Used = True Then
                    AddSymbol Imports(ii).Alias, OffsetOf(".idata"), Import, ST_IMPORT
                    AddFixup Imports(ii).Name & "_ENTRY", OffsetOf(".idata"), Import
                    AddSectionDWord &H0
                End If
            End If
        Next ii
        AddSectionDWord &H0
    Next i
    For i = 1 To UBound(Libraries)
        AddSymbol Libraries(i) & "_NAME", OffsetOf(".idata"), Import
        For ii = 1 To Len(Libraries(i))
            AddSectionByte CByte(Asc(Mid$(UCase(Libraries(i)), ii, 1)))
        Next ii
        AddSectionByte 0
    Next i
    For i = 1 To UBound(Imports)
        If Imports(i).Used = True Then
            AddSymbol Imports(i).Name & "_ENTRY", OffsetOf(".idata"), Import
            AddSectionWord 0
            For ii = 1 To Len(Imports(i).Name)
                AddSectionByte CByte(Asc(Mid$(Imports(i).Name, ii, 1)))
            Next ii
            AddSectionByte 0
        End If
    Next i
End Sub
Sub ImportLibrary()
    Dim i As Long
    Dim lIID As Long
    Dim Ident As String
    Dim FileNum As Long
    Dim NumberOfItems As Long
    Call SkipBlank: Ident = StringExpression
    If Dir(App.Path & "\include\" & Ident) = "" Then ErrMessage "cannot include "
    FileNum = FreeFile
    Open App.Path & "\include\" & Ident For Binary As #FileNum
        Get #FileNum, , NumberOfItems