创作
未分类

TWINBASIC控制台代码(一个文件)

vbaman365TWINBASIC控制台代码(一个文件)有 1 条评论


Twinbasic 代码如下：

[PredeclaredId]
Class Console
‘ 控制台操作的核心类
Private Type COORD
x As Integer
y As Integer
End Type

Private Type SMALL_RECT
    Left As Integer
    Top As Integer
    Right As Integer
    Bottom As Integer
End Type

Private Type CHAR_INFO
    UnicodeChar As Integer
    Attributes As Integer
End Type

Private Type CONSOLE_SCREEN_BUFFER_INFO
    dwSize As COORD
    dwCursorPosition As COORD
    wAttributes As Integer
    srWindow As SMALL_RECT
    dwMaximumWindowSize As COORD
End Type

Private Type CONSOLE_READCONSOLE_CONTROL
    nLength As Long
    nInitialChars As Long
    dwCtrlWakeupMask As Long
    dwControlKeyState As Long
End Type

' Windows API 声明
Private DeclareWide PtrSafe Function GetConsoleScreenBufferInfo Lib "kernel32" (ByVal hConsoleOutput As LongPtr, ByRef lpConsoleScreenBufferInfo As CONSOLE_SCREEN_BUFFER_INFO) As Long
Private DeclareWide PtrSafe Function ScrollConsoleScreenBufferW Lib "kernel32" (ByVal hConsoleOutput As LongPtr, ByRef lpScrollRectangle As SMALL_RECT, ByVal lpClipRectangle As LongPtr, ByVal dwDestinationOriginXY As Long, ByRef lpFill As CHAR_INFO) As Long
Private DeclareWide PtrSafe Function SetConsoleCursorPosition Lib "kernel32" (ByVal hConsoleOutput As LongPtr, ByVal dwCursorPosition As Long) As Long
Private DeclareWide PtrSafe Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As LongPtr
Private DeclareWide PtrSafe Function WriteConsoleW Lib "kernel32" (ByVal hConsoleOutput As LongPtr, ByVal lpBuffer As LongPtr, ByVal nNumberOfCharsToWrite As Long, ByRef lpNumberOfCharsWritten As Long, ByVal lpReserved As LongPtr) As Long
Private DeclareWide PtrSafe Function ReadConsoleW Lib "kernel32" (ByVal hConsoleInput As LongPtr, ByVal lpBuffer As LongPtr, ByVal nNumberOfCharsToRead As Long, ByRef lpNumberOfCharsRead As Long, ByVal pInputControl As LongPtr) As Long
Private DeclareWide PtrSafe Function SysAllocStringLen Lib "OleAut32" (ByVal Value As String, ByVal Length As Long) As String

' 标准句柄常量
Private Const STD_INPUT_HANDLE As Long = -10
Private Const STD_OUTPUT_HANDLE As Long = -11

Private stdIn As LongPtr
Private stdOut As LongPtr
Private inputBuffer As String

' 构造函数
Sub New(Optional MaxInputLen As Long = 256)
    stdIn = GetStdHandle(STD_INPUT_HANDLE)
    stdOut = GetStdHandle(STD_OUTPUT_HANDLE)
    inputBuffer = String(MaxInputLen, vbNullChar)
End Sub

' 清屏方法
Sub Cls()
    Dim csbi As CONSOLE_SCREEN_BUFFER_INFO
    Dim scrollRect  As SMALL_RECT
    Dim scrollTarget As COORD
    Dim fill As CHAR_INFO

    If GetConsoleScreenBufferInfo(stdOut, csbi) = 0 Then Exit Sub

    scrollRect.Left = 0
    scrollRect.Top = 0
    scrollRect.Right = csbi.dwSize.x
    scrollRect.Bottom = csbi.dwSize.y

    scrollTarget.x = 0
    scrollTarget.y = (0 - csbi.dwSize.y)

    fill.UnicodeChar = AscW(" ")
    fill.Attributes = csbi.wAttributes

    Dim scrollTargetXY As Long = scrollTarget.x Or (CLng(scrollTarget.y) << 16)
    ScrollConsoleScreenBufferW(stdOut, scrollRect, 0, scrollTargetXY, fill)

    csbi.dwCursorPosition.x = 0
    csbi.dwCursorPosition.y = 0
    Dim dwCursorPositionXY As Long = csbi.dwCursorPosition.x Or (CLng(csbi.dwCursorPosition.y) << 16)
    SetConsoleCursorPosition(stdOut, dwCursorPositionXY)
End Sub

' 输出带换行的文本
Sub WriteLine(ByVal Value As String)
    Dim writtenChars As Long
    Value &= vbLf
    WriteConsoleW(stdOut, StrPtr(Value), Len(Value), writtenChars, 0)
    If writtenChars <> Len(Value) Then Err.Raise 5, , "Console write failed"
End Sub

' 读取用户输入
Function ReadLine() As String
    Dim readChars As Long
    Dim inputControl As CONSOLE_READCONSOLE_CONTROL
    inputControl.nLength = LenB(inputControl)
    inputControl.dwCtrlWakeupMask = 1 << Asc(vbLf)
    ReadConsoleW(stdIn, StrPtr(inputBuffer), Len(inputBuffer), readChars, VarPtr(inputControl))
    ReadLine = Replace(SysAllocStringLen(inputBuffer, readChars - 1), vbCr, "")
End Function

End Class

Module MainModule
‘ 窗口API声明
Private DeclareWide PtrSafe Function CreateWindowExW Lib “user32” ( _
ByVal dwExStyle As Long, _
ByVal lpClassName As LongPtr, _
ByVal lpWindowName As LongPtr, _
ByVal dwStyle As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal hWndParent As LongPtr, _
ByVal hMenu As LongPtr, _
ByVal hInstance As LongPtr, _
ByVal lpParam As LongPtr) As LongPtr

Private DeclareWide PtrSafe Function ShowWindow Lib "user32" ( _
    ByVal hWnd As LongPtr, _
    ByVal nCmdShow As Long) As Long

Private DeclareWide PtrSafe Function UpdateWindow Lib "user32" ( _
    ByVal hWnd As LongPtr) As Long

Private DeclareWide PtrSafe Function DefWindowProcW Lib "user32" ( _
    ByVal hWnd As LongPtr, _
    ByVal wMsg As Long, _
    ByVal wParam As LongPtr, _
    ByVal lParam As LongPtr) As LongPtr

Private DeclareWide PtrSafe Function RegisterClassExW Lib "user32" ( _
    ByRef wndclass As WNDCLASSEX) As Long

Private DeclareWide PtrSafe Function GetModuleHandleW Lib "kernel32" ( _
    ByVal lpModuleName As LongPtr) As LongPtr

Private DeclareWide PtrSafe Function MessageBoxW Lib "user32" ( _
    ByVal hWnd As LongPtr, _
    ByVal lpText As LongPtr, _
    ByVal lpCaption As LongPtr, _
    ByVal uType As Long) As Long

Private DeclareWide PtrSafe Function GetMessageW Lib "user32" ( _
    ByRef lpMsg As MSG, _
    ByVal hWnd As LongPtr, _
    ByVal wMsgFilterMin As Long, _
    ByVal wMsgFilterMax As Long) As Long

Private DeclareWide PtrSafe Function TranslateMessage Lib "user32" ( _
    ByRef lpMsg As MSG) As Long

Private DeclareWide PtrSafe Function DispatchMessageW Lib "user32" ( _
    ByRef lpMsg As MSG) As Long

' 添加缺失的API声明
Private DeclareWide PtrSafe Function DestroyWindow Lib "user32" ( _
    ByVal hWnd As LongPtr) As Long

Private DeclareWide PtrSafe Sub PostQuitMessage Lib "user32" ( _
    ByVal nExitCode As Long)

Private DeclareWide PtrSafe Function GetConsoleWindow Lib "kernel32" () As LongPtr

' 添加文本处理API
Private DeclareWide PtrSafe Function GetWindowTextLengthW Lib "user32" ( _
    ByVal hWnd As LongPtr) As Long

Private DeclareWide PtrSafe Function GetWindowTextW Lib "user32" ( _
    ByVal hWnd As LongPtr, _
    ByVal lpString As LongPtr, _
    ByVal cch As Long) As Long

' 窗口常量
Private Const WS_OVERLAPPEDWINDOW As Long = &HCF0000
Private Const WS_CHILD As Long = &H40000000
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_BORDER As Long = &H800000
Private Const CW_USEDEFAULT As Long = &H80000000
Private Const SW_HIDE As Long = 0
Private Const SW_SHOWNORMAL As Long = 1
Private Const WM_DESTROY As Long = &H2
Private Const WM_CLOSE As Long = &H10
Private Const WM_COMMAND As Long = &H111
Private Const BN_CLICKED As Long = 0
Private Const ID_BUTTON As Long = 1001
Private Const ID_EDIT As Long = 1002

' 控件类名
Private Const BUTTON_CLASS As String = "Button"
Private Const EDIT_CLASS As String = "Edit"

' 消息结构
Private Type MSG
    hWnd As LongPtr
    message As Long
    wParam As LongPtr
    lParam As LongPtr
    time As Long
    pt As POINTAPI
End Type

Private Type POINTAPI
    x As Long
    y As Long
End Type

' 窗口类结构
Private Type WNDCLASSEX
    cbSize As Long
    style As Long
    lpfnWndProc As LongPtr
    cbClsExtra As Long
    cbWndExtra As Long
    hInstance As LongPtr
    hIcon As LongPtr
    hCursor As LongPtr
    hbrBackground As LongPtr
    lpszMenuName As LongPtr
    lpszClassName As LongPtr
    hIconSm As LongPtr
End Type

' 全局变量
Private hEdit As LongPtr
Private hButton As LongPtr
Private hMainWnd As LongPtr
Private WindowProcPtr As LongPtr

' 自定义窗口过程
Private Function WindowProc( _
    ByVal hWnd As LongPtr, _
    ByVal uMsg As Long, _
    ByVal wParam As LongPtr, _
    ByVal lParam As LongPtr) As LongPtr

    Select Case uMsg
        Case WM_COMMAND
            ' 处理按钮点击
            If LoWord(wParam) = ID_BUTTON Then
                If HiWord(wParam) = BN_CLICKED Then
                    ' 获取编辑框内容
                    Dim textLength As Long
                    Dim textBuffer As String

                    textLength = GetWindowTextLengthW(hEdit) + 1
                    textBuffer = String(textLength, vbNullChar)
                    GetWindowTextW hEdit, StrPtr(textBuffer), textLength

                    ' 显示消息框
                    MessageBoxW hWnd, StrPtr("You entered: " & textBuffer), StrPtr("Input"), 0
                End If
            End If

        Case WM_CLOSE
            ' 销毁窗口
            DestroyWindow hWnd

        Case WM_DESTROY
            ' 退出消息循环
            PostQuitMessage 0
            WindowProc = 0
            Exit Function
    End Select

    ' 默认消息处理
    WindowProc = DefWindowProcW(hWnd, uMsg, wParam, lParam)
End Function

' 辅助函数: 获取低16位 (修复类型转换问题)
Private Function LoWord(ByVal dw As LongPtr) As Long
    LoWord = CLng(dw And &HFFFF&)
End Function

' 辅助函数: 获取高16位 (修复类型转换问题)
Private Function HiWord(ByVal dw As LongPtr) As Long
    HiWord = CLng((dw \ &H10000) And &HFFFF&)
End Function

' 创建主窗口
Private Function CreateMainWindow() As Boolean
    Dim wc As WNDCLASSEX
    Dim hInstance As LongPtr
    Dim className As String

    ' 获取当前实例句柄
    hInstance = GetModuleHandleW(0)

    ' 注册窗口类
    className = "tWinMainClass"
    wc.cbSize = LenB(wc)
    wc.style = 0
    wc.lpfnWndProc = WindowProcPtr
    wc.cbClsExtra = 0
    wc.cbWndExtra = 0
    wc.hInstance = hInstance
    wc.hIcon = 0
    wc.hCursor = 0
    wc.hbrBackground = 0  ' 系统默认背景
    wc.lpszMenuName = 0
    wc.lpszClassName = StrPtr(className)
    wc.hIconSm = 0

    If RegisterClassExW(wc) = 0 Then
        MessageBoxW 0, StrPtr("Failed to register window class"), StrPtr("Error"), 0
        CreateMainWindow = False
        Exit Function
    End If

    ' 创建窗口
    hMainWnd = CreateWindowExW( _
        0, _
        StrPtr(className), _
        StrPtr("twinBASIC GUI Application"), _
        WS_OVERLAPPEDWINDOW, _
        CW_USEDEFAULT, _
        CW_USEDEFAULT, _
        400, _
        300, _
        0, _
        0, _
        hInstance, _
        0)

    If hMainWnd = 0 Then
        MessageBoxW 0, StrPtr("Failed to create window"), StrPtr("Error"), 0
        CreateMainWindow = False
        Exit Function
    End If

    ' ' 创建编辑框 - 修复行连续符问题
    '  hEdit = CreateWindowExW(0, StrPtr(EDIT_CLASS), StrPtr(""), 20, 20, 25, ID_EDIT, hInstance, 0)

    ' ' 创建按钮 - 修复行连续符问题
    ' hButton = CreateWindowExW(0, StrPtr(BUTTON_CLASS), StrPtr("Show Text"), WS_VISIBLE Or WS_CHILD, 150, 60, 100, 30, hMainWnd, ID_BUTTON, hInstance, 0)

    ' 显示窗口
    ShowWindow hMainWnd, SW_SHOWNORMAL
    UpdateWindow hMainWnd

    CreateMainWindow = True
End Function

' 消息循环
Private Sub RunMessageLoop()
    Dim msg As MSG

    ' 主消息循环
    While GetMessageW(msg, 0, 0, 0) <> 0
        TranslateMessage msg
        DispatchMessageW msg
    Wend
End Sub

' 隐藏控制台窗口
Private Sub HideConsoleWindow()
    Dim hConsole As LongPtr
    hConsole = GetConsoleWindow()
    If hConsole <> 0 Then
        ShowWindow hConsole, SW_HIDE
    End If
End Sub

' 程序入口点
Public Sub Main()
    ' 隐藏控制台窗口
    HideConsoleWindow

    ' 获取窗口过程指针
    WindowProcPtr = ProcPtr(AddressOf WindowProc)

    ' 创建主窗口
    If Not CreateMainWindow() Then Exit Sub

    ' 运行消息循环
    RunMessageLoop
End Sub

' twinBASIC 获取函数指针的正确方法
Private Function ProcPtr(ByVal Proc As LongPtr) As LongPtr
    ProcPtr = Proc
End Function

End Module

Hi, I’m vbaman365

近期文章

One Comment

发表回复