Code: Select all
#cmdline "-s console"
#Include "win\shlobj.bi"
#Include "win\tlhelp32.bi"
#Include "windows.bi"
Function _WinAPI_GetBinaryType(sFilename As String) As DWORD
Dim As DWORD lpBinaryType
If GetBinaryTypeW(sFilename, @lpBinaryType) = 0 Then Return -1 'https://learn.microsoft.com/en-us/windows/win32/api/winbase/nf-winbase-getbinarytypew
Return lpBinaryType
End Function
Function _WinAPI_FindFile(sPath As String, sFilename As String) As String
Dim As WIN32_FIND_DATA FindFileData
Dim As HANDLE hFind
Static As String sFile, sTmp
hFind = FindFirstFile(sPath, @FindFileData)
If hFind = INVALID_HANDLE_VALUE Then Return ""
While FindNextFile(hFind, @FindFileData) <> 0
If FindFileData.cFileName <> ".." Then
If (FindFileData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then Return _WinAPI_FindFile(Left(sPath, InStrRev(sPath, "\")) & FindFileData.cFileName & "\*", sFilename)
sTmp = Rtrim(sPath, "*") & sFilename
Dim As Dword lpBinaryType = _WinAPI_GetBinaryType(sTmp)
If FindFileData.cFileName = sFilename And (lpBinaryType = 6 Or lpBinaryType = 0) Then sFile = sTmp
Endif
Wend
FindClose(hFind)
Return sFile
End Function
Function _WinAPI_IsOSx86() As Boolean 'https://learn.microsoft.com/en-us/windows/win32/api/sysinfoapi/nf-sysinfoapi-getnativesysteminfo?redirectedfrom=MSDN
Dim As SYSTEM_INFO lpSystemInfo
GetNativeSystemInfo(@lpSystemInfo)
Return lpSystemInfo.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_INTEL
End Function
Function _WinAPI_GetParentProcess(iPID As Integer = 0) As Integer
Dim As DWORD pid = Iif(iPID = 0, GetCurrentProcessId(), iPID), pid_parent = 0
Dim As HANDLE hSnapshot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
Dim As PROCESSENTRY32 tPROCESSENTRY32
tPROCESSENTRY32.dwSize = Sizeof(tPROCESSENTRY32)
Process32First(hSnapshot, @tPROCESSENTRY32)
While TRUE
If tPROCESSENTRY32.th32ProcessID = pid Then
pid_parent = tPROCESSENTRY32.th32ParentProcessID
Exit While
End If
Process32Next(hSnapshot, @tPROCESSENTRY32)
Wend
CloseHandle(hSnapshot)
Return pid_parent
End Function
Function _WinAPI_GetProcessName(iPid As DWORD) As String
Dim As HANDLE hSnapshot = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, iPid)
If hSnapshot = 0 Then Return ""
Dim As PROCESSENTRY32W tPROCESSENTRY32W
tPROCESSENTRY32W.dwSize = Sizeof(PROCESSENTRY32W)
Process32FirstW(hSnapshot, @tPROCESSENTRY32W)
While True
If tPROCESSENTRY32W.th32ProcessID = iPid Then Exit While
If Process32NextW(hSnapshot, @tPROCESSENTRY32W) = 0 Then Exit While
Wend
CloseHandle(hSnapshot)
Return tPROCESSENTRY32W.szExeFile
End Function
Function _WinAPI_TerminateProcess(iPID As Integer, iExitCode As Integer = 0, bInheritHandle As Boolean = True) As Boolean
Dim As Long dwDesiredAccess = PROCESS_TERMINATE
Dim As Handle hProcess = OpenProcess(dwDesiredAccess, bInheritHandle, iPID)
If hProcess = Null Then Return False
TerminateProcess(hProcess, iExitCode)
CloseHandle(hProcess)
Return True
End Function
Sub GetCommandLineArguments(Byref sArguments As String)
Dim As Ubyte i = 1
Dim As String s
While True
s = Command(i)
If Len(s) = 0 Then Exit While
sArguments &= s & " "
i += 1
Wend
End Sub
Sub SetConsoleSize(cols As Long, lines As Long)
Shell "MODE CON: COLS=" + Str(cols) + "LINES=" + Str(lines)
End Sub
Declare Function RtlGetVersion Lib "NtDll.dll" Alias "RtlGetVersion" (OsVersionInformation As RTL_OSVERSIONINFOW) As Long
Dim As RTL_OSVERSIONINFOW OS
OS.dwOSVersionInfoSize = Sizeof(RTL_OSVERSIONINFOW)
RtlGetVersion(OS)
Dim Shared As HWND hConsole
Dim As Handle hStdOut, hStdIn
AllocConsole()
hStdOut = GetStdHandle(STD_OUTPUT_HANDLE)
hStdIn = GetStdHandle(STD_INPUT_HANDLE)
hConsole = GetConsoleWindow()
SetConsoleSize(80, 15)
Dim As Integer iStyle = GetWindowLong(hConsole, GWL_STYLE)
Dim As Wstring * 4096 sClassname
GetClassNameW(hConsole, @sClassname, 4096)
Dim As String sArguments = " "
GetCommandLineArguments(sArguments)
'Restert exe if it is in a Terminal Window
If (SendMessageW(hConsole, WM_GETICON, Iif(OS.dwBuildNumber < 9200, 1, 0), 0) = 0 And sClassname = "PseudoConsoleWindow") And Command(1) <> "restart" Then 'restart app in CMD window
#ifdef __FB_64BIT__
Shell("conhost.exe """ & Command(0) & """ restart" & sArguments)
#Else
If _WinAPI_IsOSx86() = False Then
Dim As String sConhost = _WinAPI_FindFile("C:\Windows\WinSxS\amd64_microsoft-onecore-console-host-core_*", "conhost.exe")
'If sConhost <> "" Then Shell("""" & sConhost & """" & " """ & Command(0) & """ restart" & sArguments)
If sConhost <> "" Then
Shell(sConhost & " """ & Command(0) & """ restart" & sArguments)
Else
? "Couldn't find conhost.exe"
Sleep
Endif
Else
Shell("conhost.exe """ & Command(0) & """ restart" & sArguments)
Endif
#endif
FreeConsole()
End 1000
Endif
If Command(1) = "restart" Then
Dim As String exeName = Mid(Command(0), Instrrev(Command(0), "/") + 1, Len(Command(0)))
Dim As Ubyte countParentPIDs = 0
Dim As Integer iPID, parentPID = _WinAPI_GetParentProcess()
While True
iPID = _WinAPI_GetParentProcess(parentPID)
If _WinAPI_GetProcessName(iPID) <> "cmd.exe" Then
parentPID = iPID
countParentPIDs += 1
If countParentPIDs > 5 Then Exit While
Else
_WinAPI_TerminateProcess(iPID, 0, True)
Exit While
Endif
Wend
Endif
Dim Shared As Integer iOldStyle
iOldStyle = GetWindowLong(hConsole, GWL_STYLE)
SetWindowLong(hConsole, GWL_STYLE, iOldStyle And Not WS_MAXIMIZEBOX And Not WS_VSCROLL And Not WS_HSCROLL) 'Not WS_SIZEBOX And
Dim Shared As LONG_PTR g_OldWndProc
Function WindowProc(hWnd As HWND, uMsg As UINT, wParam As WPARAM, lParam As LPARAM) As LRESULT
Select Case uMsg
Case WM_CLOSE
PostQuitMessage(0)
Case WM_WINDOWPOSCHANGING
Dim As WINDOWPOS Ptr tWinPos
tWinPos = Cast(WINDOWPOS Ptr, lParam)
? tWinPos->cx, tWinPos->cy
Return 0
End Select
? hWnd, hConsole, uMsg
Return CallWindowProc(Cast(WNDPROC, g_OldWndProc), hwnd, uMsg, wParam, lParam)
End Function
g_OldWndProc = SetWindowLongPtr(hConsole, GWLP_WNDPROC, Cast(LONG_PTR, @WindowProc))
If g_OldWndProc = 0 Then ? "Error subclassing hConsole"
Dim msg As MSG
While GetMessage(@msg, 0, 0, 0)
TranslateMessage(@msg)
DispatchMessage(@msg)
Wend
SetWindowLongPtr(hCOnsole, GWLP_WNDPROC, Cast(LONG_PTR, @g_OldWndProc))
FreeConsole()
Any idea?
