Index: Include/Classes/System/Environment.ab =================================================================== --- Include/Classes/System/Environment.ab (revision 257) +++ Include/Classes/System/Environment.ab (revision 258) @@ -3,4 +3,10 @@ #require #require + +Namespace System + +Namespace Detail + TypeDef PFNGetProcessMemoryInfo = *Function(Process As HANDLE, ByRef mc As PROCESS_MEMORY_COUNTERS, cb As DWord) As BOOL +End Namespace Class Environment @@ -45,5 +51,13 @@ End Function - ' MachineName + Static Function MachineName() As String + If Object.ReferenceEquals(machineName, Nothing) Then + Dim buf[MAX_COMPUTERNAME_LENGTH] As TCHAR + Dim len = (MAX_COMPUTERNAME_LENGTH + 1) As DWord + GetComputerName(buf, len) + machineName = New String(buf, len As Long) + End If + Return machineName + End Function Static Function NewLine() As String @@ -90,14 +104,22 @@ ' UserInteractive - ' UserName + Static Function UserName() As String + If Object.ReferenceEquals(userName, Nothing) Then + Dim buf[UNLEN] As TCHAR + Dim len = (UNLEN + 1) As DWord + GetUserName(buf, len) + userName = New String(buf, len As Long) + End If + Return userName + End Function ' Version +Public + 'NTでしか使用できない仕様 Static Function WorkingSet() As Int64 - TypeDef PFNGetProcessMemoryInfo = *Function(Process As HANDLE, ByRef mc As PROCESS_MEMORY_COUNTERS, cb As DWord) As BOOL - Dim pGetProcessMemoryInfo As PFNGetProcessMemoryInfo Dim hmodPSAPI = LoadLibrary("PSAPI.DLL") If hmodPSAPI = 0 Then Return 0 - pGetProcessMemoryInfo = GetProcAddress(hmodPSAPI, ToMBStr("GetProcessMemoryInfo")) As PFNGetProcessMemoryInfo + Dim pGetProcessMemoryInfo = GetProcAddress(hmodPSAPI, ToMBStr("GetProcessMemoryInfo")) As Detail.PFNGetProcessMemoryInfo If pGetProcessMemoryInfo <> 0 Then Dim mc As PROCESS_MEMORY_COUNTERS @@ -136,4 +158,13 @@ ' GetEnvironmentVariables + Static Function GetFolderPath(f As Environment_SpecialFolder) As String +' If ... Then +' Throw New ArgumentException +' End If + Dim x As Long + x = f + Return ActiveBasic.Windows.GetFolderPath(x) + End Function + ' GetLogicalDrives @@ -143,6 +174,37 @@ Static cmdLine = Nothing As String Static exitCode = 0 As Long + Static machineName = Nothing As String Static osVer = Nothing As OperatingSystem Static processorCount = 0 As Long Static sysDir = Nothing As String + Static userName = Nothing As String End Class + +Enum Environment_SpecialFolder + Desktop = CSIDL_DESKTOP + Programs = CSIDL_PROGRAMS + Personal = CSIDL_PERSONAL + MyDocuments = CSIDL_PERSONAL + Favorites = CSIDL_FAVORITES + Startup = CSIDL_STARTUP + Recent = CSIDL_RECENT + SendTo = CSIDL_SENDTO + StartMenu = CSIDL_STARTMENU + MyMusic = CSIDL_MYMUSIC + DesktopDirectory = CSIDL_DESKTOPDIRECTORY + MyComputer = CSIDL_DRIVES + Templates = CSIDL_TEMPLATES + ApplicationData = CSIDL_APPDATA '4.71 + LocalApplicationData = CSIDL_LOCAL_APPDATA + InternetCache = CSIDL_INTERNET_CACHE + Cookies = CSIDL_COOKIES + History = CSIDL_HISTORY + CommonApplicationData = CSIDL_COMMON_APPDATA '5.0 + System = CSIDL_SYSTEM + CommonProgramFiles = CSIDL_PROGRAM_FILES + ProgramFiles = CSIDL_PROGRAM_FILES + MyPictures = CSIDL_MYPICTURES +End Enum + + +End Namespace 'System Index: Include/Classes/System/OperatingSystem.ab =================================================================== --- Include/Classes/System/OperatingSystem.ab (revision 257) +++ Include/Classes/System/OperatingSystem.ab (revision 258) @@ -6,9 +6,11 @@ #require +Namespace System + Class OperatingSystem ' Inherits ICloneable', ISerializable Public ' Constractor - Sub OperatingSystem(platform As PlatformID, version As System.Version) + Sub OperatingSystem(platform As PlatformID, version As Version) pf = platform ver = version @@ -18,5 +20,5 @@ Sub OperatingSystem(vi As OSVERSIONINFOA) pf = vi.dwPlatformId As PlatformID - ver = New System.Version(vi.dwMajorVersion, vi.dwMinorVersion, vi.dwBuildNumber) + ver = New Version(vi.dwMajorVersion, vi.dwMinorVersion, vi.dwBuildNumber) sp = New String(vi.szCSDVersion As PCSTR) End Sub @@ -24,5 +26,5 @@ Sub OperatingSystem(vi As OSVERSIONINFOW) pf = vi.dwPlatformId As PlatformID - ver = New System.Version(vi.dwMajorVersion, vi.dwMinorVersion, vi.dwBuildNumber) + ver = New Version(vi.dwMajorVersion, vi.dwMinorVersion, vi.dwBuildNumber) sp = New String(vi.szCSDVersion As PCSTR) End Sub @@ -33,5 +35,5 @@ End Function - Const Function Version() As System.Version + Const Function Version() As Version Return ver End Function @@ -71,5 +73,5 @@ Private pf As PlatformID - ver As System.Version + ver As Version sp As String End Class @@ -83,3 +85,5 @@ End Enum +End Namespace + #endif '__SYSYTEM_OPERATINGSYSTEM_AB__ Index: Include/Classes/System/Threading/WaitHandle.ab =================================================================== --- Include/Classes/System/Threading/WaitHandle.ab (revision 257) +++ Include/Classes/System/Threading/WaitHandle.ab (revision 258) @@ -3,4 +3,11 @@ #ifndef __SYSTEM_THREADING_WAITHANDLE_AB__ #define __SYSTEM_THREADING_WAITHANDLE_AB__ + +'Namespace System +'Namespace Threading + +Namespace Detail + TypeDef PFNSignalObjectAndWait = *Function(hObjectToSignal As HANDLE, hObjectToWaitOn As HANDLE, dwMilliseconds As DWord, bAlertable As DWord) As DWord +End Namespace Class WaitHandle @@ -62,7 +69,7 @@ End Function +Public Static Function SignalAndWait(ByRef toSignal As WaitHandle, ByRef toWaitOn As WaitHandle, millisecondsTimeout As Long, exitContext As BOOL) As BOOL - TypeDef PFNSignalObjectAndWait = *Function(hObjectToSignal As HANDLE, hObjectToWaitOn As HANDLE, dwMilliseconds As DWord, bAlertable As DWord) As DWord - Dim pSignalObjectAndWait = GetProcAddress(GetModuleHandle("Kernel32.dll"), "SignalObjectAndWait") As PFNSignalObjectAndWait + Dim pSignalObjectAndWait = GetProcAddress(GetModuleHandle("Kernel32.dll"), "SignalObjectAndWait") As Detail.PFNSignalObjectAndWait If pSignalObjectAndWait = 0 Then ' PlatformNotSupportedException @@ -105,3 +112,6 @@ End Class +'End Namespace 'Threading +'End Namespace 'System + #endif '__SYSTEM_THREADING_WAITHANDLE_AB__ Index: Include/api_shell.sbp =================================================================== --- Include/api_shell.sbp (revision 257) +++ Include/api_shell.sbp (revision 258) @@ -374,4 +374,6 @@ ' ShlObj.h + +'要IE4 Declare Function SHGetSpecialFolderPath Lib "shell32" Alias _FuncName_SHGetSpecialFolderPath (hwndOwner As HWND, lpszPath As LPTSTR, nFolder As Long, fCreate As BOOL) As BOOL @@ -379,6 +381,54 @@ Declare Function SHGetInstanceExplorer Lib "shell32" (ByRef ppunk As *IUnknown) As HRESULT -Const CSIDL_PERSONAL = 5 -Const CSIDL_FAVORITIES = 6 +'shlobj.h +Declare Function SHGetSpecialFolderLocation Lib "shell32" (hwndOwner As HWND, nFolder As Long, ByRef pidl As LPITEMIDLIST) As HRESULT + +'shlobj.h +'要Win2k/Me +'Declare Function SHGetFolderLocation Lib "shell32" (hwndOwner As HWND, nFolder As Long, hToken As HANDLE, dwReserved As DWord, ByRef pidl As LPITEMIDLIST) As HRESULT + +Const CSIDL_DESKTOP = &h0000 +Const CSIDL_INTERNET = &h0001 +Const CSIDL_PROGRAMS = &h0002 +Const CSIDL_CONTROLS = &h0003 +Const CSIDL_PRINTERS = &h0004 +Const CSIDL_PERSONAL = &h0005 +Const CSIDL_FAVORITES = &h0006 +Const CSIDL_STARTUP = &h0007 +Const CSIDL_RECENT = &h0008 +Const CSIDL_SENDTO = &h0009 +Const CSIDL_BITBUCKET = &h000a +Const CSIDL_STARTMENU = &h000b +Const CSIDL_MYMUSIC = &h000d +Const CSIDL_DESKTOPDIRECTORY = &h0010 +Const CSIDL_DRIVES = &h0011 +Const CSIDL_NETWORK = &h0012 +Const CSIDL_NETHOOD = &h0013 +Const CSIDL_FONTS = &h0014 +Const CSIDL_TEMPLATES = &h0015 +Const CSIDL_COMMON_STARTMENU = &h0016 +Const CSIDL_COMMON_PROGRAMS = &h0017 +Const CSIDL_COMMON_STARTUP = &h0018 +Const CSIDL_COMMON_DESKTOPDIRECTORY = &h0019 +Const CSIDL_APPDATA = &h001a +Const CSIDL_PRINTHOOD = &h001b +Const CSIDL_LOCAL_APPDATA = &h001c +Const CSIDL_ALTSTARTUP = &h001d +Const CSIDL_COMMON_ALTSTARTUP = &h001e +Const CSIDL_COMMON_FAVORITES = &h001f +Const CSIDL_INTERNET_CACHE = &h0020 +Const CSIDL_COOKIES = &h0021 +Const CSIDL_HISTORY = &h0022 +Const CSIDL_COMMON_APPDATA = &h0023 +Const CSIDL_WINDOWS = &h0024 +Const CSIDL_SYSTEM = &h0025 +Const CSIDL_PROGRAM_FILES = &h0026 +Const CSIDL_MYPICTURES = &h0027 +Const CSIDL_PROFILE = &h0028 +Const CSIDL_PROGRAM_FILES_COMMON = &h002b +Const CSIDL_COMMON_TEMPLATES = &h002d +Const CSIDL_COMMON_DOCUMENTS = &h002e +Const CSIDL_COMMON_ADMINTOOLS = &h002f +Const CSIDL_ADMINTOOLS = &h0030 Const SHGFI_ICON = &H000000100 Index: Include/api_system.sbp =================================================================== --- Include/api_system.sbp (revision 257) +++ Include/api_system.sbp (revision 258) @@ -213,4 +213,7 @@ Const MUTEX_ALL_ACCESS = MUTANT_ALL_ACCESS +'Lmcons.ab +Const UNLEN = 256 + '---------------------- ' Kernel Operation API @@ -465,5 +468,5 @@ Const MAX_COMPUTERNAME_LENGTH = 15 -Declare Function GetComputerName Lib "kernel32" Alias _FuncName_GetComputerName (pBuffer As PTSTR, ByRef nSize As Long) As Long +Declare Function GetComputerName Lib "kernel32" Alias _FuncName_GetComputerName (pBuffer As PTSTR, ByRef nSize As DWord) As BOOL Declare Function GetCurrentDirectory Lib "kernel32" Alias _FuncName_GetCurrentDirectory (nBufferLength As DWord, pBuffer As PTSTR) As DWord Index: Include/basic.sbp =================================================================== --- Include/basic.sbp (revision 257) +++ Include/basic.sbp (revision 258) @@ -12,7 +12,22 @@ End Sub +Const QWORD_MAX = &HFFFFFFFFFFFFFFFF As QWord +Const INT64_MAX = &H7FFFFFFFFFFFFFFF As Int64 +Const INT64_MIN = &H8000000000000000 As Int64 -Const LONG_MAX = &H7FFFFFFF -Const LONG_MIN = &H80000000 +Const DWORD_MAX = &HFFFFFFFF As DWord +Const LONG_MAX = &H7FFFFFFF As Long +Const LONG_MIN = &H80000000 As Long + +Const WORD_MAX = &HFFFF As Word +Const INTEGER_MAX = &H7FFF As Integer +Const INTEGER_MIN = &H8000 As Integer + +Const BYTE_MAX = &HFF As Byte +Const SBYTE_MAX = &H7F As SByte +Const SBYTE_MIN = &H80 As SByte + +Const DBL_MAX = 1.7976931348623158e+308 +Const DBL_MIN = 2.2250738585072014e-308 Const FLT_MAX = 3.402823466e+38 Index: Include/basic/command.sbp =================================================================== --- Include/basic/command.sbp (revision 257) +++ Include/basic/command.sbp (revision 258) @@ -34,5 +34,5 @@ Sub _System_End() - Dim exitCode = Environment.ExitCode + Dim exitCode = System.Environment.ExitCode _System_EndProgram() ExitProcess(exitCode) Index: Include/basic/function.sbp =================================================================== --- Include/basic/function.sbp (revision 257) +++ Include/basic/function.sbp (revision 258) @@ -1231,3 +1231,31 @@ End Function +Namespace ActiveBasic + Namespace Windows + Function GetPathFromIDList(pidl As LPITEMIDLIST) As String + Dim buf[ELM(MAX_PATH)] As TCHAR + If SHGetPathFromIDList(pidl, buf) Then + Return New String(buf) + Else + Return "" + End If + End Function + + Function GetFolderPath(hwnd As HWND, folder As Long) As String + Dim pidl As LPITEMIDLIST + Dim hr = SHGetSpecialFolderLocation(hwnd, folder, pidl) + If SUCCEEDED(hr) Then + GetFolderPath = GetPathFromIDList(pidl) + CoTaskMemFree(pidl) + Else + GetFolderPath = "" + End If + End Function + + Function GetFolderPath(folder As Long) As String + Return GetFolderPath(0, folder) + End Function + End Namespace +End Namespace + #endif '_INC_FUNCTION Index: Include/basic/prompt.sbp =================================================================== --- Include/basic/prompt.sbp (revision 257) +++ Include/basic/prompt.sbp (revision 258) @@ -5,8 +5,12 @@ #define _INC_PROMPT - #require #require - +#require + +Namespace ActiveBasic +Namespace Prompt +Namespace Detail + Function _PromptSys_GetTextExtentPoint32(hdc As HDC, psz As PCSTR, cb As Long, ByRef Size As SIZE) As Long _PromptSys_GetTextExtentPoint32 = GetTextExtentPoint32A(hdc, psz, cb, Size) @@ -50,9 +54,8 @@ End Type -Dim _PromptSys_LogFont As LOGFONT Dim _PromptSys_hFont As HFONT Dim _PromptSys_FontSize As SIZE Dim _PromptSys_InputStr[255] As StrChar -Dim _PromptSys_InputLen As Long +Dim _PromptSys_InputLen = -1 As Long Dim _PromptSys_KeyChar As Byte Dim _PromptSys_CurPos As POINTAPI @@ -64,5 +67,4 @@ Dim _System_OSVersionInfo As OSVERSIONINFO -_PromptSys_InputLen = -1 'graphic @@ -72,7 +74,7 @@ Dim _PromptSys_GlobalPos As POINTAPI +Sub _PromptSys_Initialize() _PromptSys_hInitFinish = CreateEvent(0, FALSE, FALSE, 0) -Dim _PromptSys_hThread As HANDLE -_PromptSys_hThread = CreateThread(0, 0, AddressOf(PromptMain) As LPTHREAD_START_ROUTINE, 0, 0, _PromptSys_dwThreadID) +Dim _PromptSys_hThread = CreateThread(0, 0, AddressOf(PromptMain), 0, 0, _PromptSys_dwThreadID) If _PromptSys_hThread = 0 Then Debug @@ -80,4 +82,5 @@ End If WaitForSingleObject(_PromptSys_hInitFinish, INFINITE) +End Sub Sub DrawPromptBuffer(hDC As HDC, StartLine As Long, EndLine As Long) @@ -267,8 +270,8 @@ Dim ps As PAINTSTRUCT Dim hdc = BeginPaint(hwnd, ps) -' With _PromptSys_ScreenSize -' BitBlt(hdc, 0, 0, .cx, .cy, _PromptSys_hMemDC, 0, 0, SRCCOPY) - With ps.rcPaint - BitBlt(hdc, .left, .top, .right - .left, .bottom - .top, _PromptSys_hMemDC, .left, .top, SRCCOPY) + With _PromptSys_ScreenSize + BitBlt(hdc, 0, 0, .cx, .cy, _PromptSys_hMemDC, 0, 0, SRCCOPY) +' With ps.rcPaint +' BitBlt(hdc, .left, .top, .right - .left, .bottom - .top, _PromptSys_hMemDC, .left, .top, SRCCOPY) End With DrawPromptBuffer(hdc, -1, 0) @@ -287,5 +290,8 @@ End With ImmSetCompositionWindow(himc, CompForm) - ImmSetCompositionFont(himc, _PromptSys_LogFont) + + Dim lf As LOGFONT + GetObject(_PromptSys_hFont, Len(lf), lf) + ImmSetCompositionFont(himc, lf) End If ImmReleaseContext(hwnd, himc) @@ -365,5 +371,5 @@ SendMessage(hwnd, WM_KILLFOCUS, 0, 0) - PRINT_ToPrompt(TempStr) + ActiveBasic.Prompt.Detail.PRINT_ToPrompt(TempStr) SendMessage(hwnd, WM_SETFOCUS, 0, 0) End If @@ -372,5 +378,5 @@ Function _PromptWnd_GetCompositionStringW(himc As HIMC, ByRef rpsz As PWSTR) As Long Dim size = ImmGetCompositionStringW(himc, GCS_RESULTSTR, 0, 0) 'sizeはバイト単位 - rpsz = _System_malloc(size) As PTSTR + rpsz = _System_malloc(size) As PWSTR If rpsz = 0 Then 'Debug @@ -382,5 +388,5 @@ Function _PromptWnd_GetCompositionStringA(himc As HIMC, ByRef rpsz As PSTR) As Long Dim size = ImmGetCompositionStringA(himc, GCS_RESULTSTR, 0, 0) 'sizeはバイト単位 - rpsz = _System_malloc(size) As PTSTR + rpsz = _System_malloc(size) As PSTR If rpsz = 0 Then 'Debug @@ -403,7 +409,8 @@ tempStr.Assign(str, size) #else - With _System_OSVersionInfo + Dim osver = System.Environment.OSVersion + With osver ' GetCompositionStringW is not implimented in Windows 95 - If .dwMajorVersion = 4 And .dwMinorVersion = 0 And .dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then + If .Version.Major = 4 And .Version.Minor = 0 And .Platform = System.PlatformID.Win32Windows Then Dim strA As PCSTR Dim sizeA = _PromptWnd_GetCompositionStringA(himc, strA) @@ -421,6 +428,6 @@ _PromptSys_InputLen += tempStr.Length - SendMessage(hwnd, WM_KILLFOCUS, 0, 0) : Debug - PRINT_ToPrompt(tempStr) + SendMessage(hwnd, WM_KILLFOCUS, 0, 0) + ActiveBasic.Prompt.Detail.PRINT_ToPrompt(tempStr) SendMessage(hwnd, WM_SETFOCUS, 0, 0) @@ -454,6 +461,7 @@ End With - 'LogFont initialize - With _PromptSys_LogFont + '_PromptSys_hFont initialize + Dim lf As LOGFONT + With lf .lfHeight = -16 .lfWidth = 0 @@ -469,8 +477,8 @@ .lfQuality = DEFAULT_QUALITY .lfPitchAndFamily = FIXED_PITCH - lstrcpy(.lfFaceName, "ＭＳ 明朝") - End With - - _PromptSys_hFont = CreateFontIndirect(_PromptSys_LogFont) + lstrcpy(.lfFaceName, ToTCStr("ＭＳ 明朝")) + End With + + _PromptSys_hFont = CreateFontIndirect(lf) 'Critical Section @@ -487,5 +495,5 @@ .hIconSm = LoadImage(0, MAKEINTRESOURCE(IDI_WINLOGO), IMAGE_ICON, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HICON .hCursor = LoadImage(0, MAKEINTRESOURCE(IDC_ARROW), IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HCURSOR - .lpszClassName = "PROMPT" + .lpszClassName = ToTCStr("PROMPT") .lpfnWndProc = AddressOf(PromptProc) .hbrBackground = GetStockObject(BLACK_BRUSH) @@ -494,5 +502,5 @@ 'Create Prompt Window - _PromptSys_hWnd = CreateWindowEx(WS_EX_CLIENTEDGE, atom As ULONG_PTR As LPCTSTR, "BASIC PROMPT", _ + _PromptSys_hWnd = CreateWindowEx(WS_EX_CLIENTEDGE, atom As ULONG_PTR As LPCTSTR, ToTCStr("BASIC PROMPT"), _ WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _ 0, 0, wcl.hInstance, 0) @@ -503,5 +511,10 @@ Do Dim iResult = GetMessage(msg, 0, 0, 0) - If iResult = 0 Or iResult = -1 Then Exit Do + If iResult = 0 Then + System.Environment.ExitCode = msg.wParam As Long + Exit Do + ElseIf iResult = -1 Then + Exit Do + End If TranslateMessage(msg) DispatchMessage(msg) @@ -509,5 +522,5 @@ '強制的に終了する - End 'ExitProcess(0) + End EnterCriticalSection(_PromptSys_SectionOfBufferAccess) @@ -522,19 +535,16 @@ DeleteCriticalSection(_PromptSys_SectionOfBufferAccess) - End 'ExitProcess(0) -End Function - - -'---------------------- -' Prompt text Commands -'---------------------- - -Macro CLS()(num As Long) + End +End Function + +'Prompt text command functoins + +Sub Cls(n As Long) Dim i As Long 'When parameter was omitted, num is set to 1 - If num = 0 Then num = 1 - - If num = 1 Or num = 3 Then + If n = 0 Then n = 1 + + If n = 1 Or n = 3 Then 'Clear the text screen For i = 0 To 100 @@ -550,5 +560,5 @@ End If - If num = 2 Or num = 3 Then + If n = 2 Or n = 3 Then 'Clear the graphics screen Dim hOldBrush = SelectObject(_PromptSys_hMemDC, GetStockObject(BLACK_BRUSH)) @@ -561,20 +571,16 @@ 'Redraw InvalidateRect(_PromptSys_hWnd, ByVal 0, 0) -End Macro - -Macro COLOR(TextColorCode As Long)(BackColorCode As Long) - _PromptSys_NowTextColor = GetBasicColor(TextColorCode) - If BackColorCode = -1 Then +End Sub + +Sub Color(textColorCode As Long, backColorCode As Long) + _PromptSys_NowTextColor = GetBasicColor(textColorCode) + If backColorCode = -1 Then _PromptSys_NowBackColor = -1 Else - _PromptSys_NowBackColor = GetBasicColor(BackColorCode) - End If -End Macro - -'---------- Defined in "command.sbp" ---------- -'Dim _System_InputDataPtr[_System_MAX_PARMSNUM] As VoidPtr -'Dim _System_InputDataType[_System_MAX_PARMSNUM] As DWord -'---------------------------------------------- -Sub INPUT_FromPrompt(ShowStr As String) + _PromptSys_NowBackColor = GetBasicColor(backColorCode) + End If +End Sub + +Sub INPUT_FromPrompt(showStr As String) Dim i As Long, i2 As Long, i3 As Long Dim buf As String @@ -582,5 +588,5 @@ *InputReStart - PRINT_ToPrompt(ShowStr) + ActiveBasic.Prompt.Detail.PRINT_ToPrompt(showStr) 'Input by keyboard @@ -616,9 +622,9 @@ i++ If _System_InputDataPtr[i] = 0 and _PromptSys_InputStr[i2] = &h2c Then 'Asc(",") - PRINT_ToPrompt(Ex"入力データの個数が多すぎます\r\n") + ActiveBasic.Prompt.Detail.PRINT_ToPrompt(Ex"入力データの個数が多すぎます\r\n") Goto *InputReStart ElseIf _PromptSys_InputStr[i2] = 0 Then If _System_InputDataPtr[i]<>0 Then - PRINT_ToPrompt(Ex"入力データの個数が足りません\r\n") + ActiveBasic.Prompt.Detail.PRINT_ToPrompt(Ex"入力データの個数が足りません\r\n") Goto *InputReStart Else @@ -631,9 +637,5 @@ End Sub -Sub PRINTUSING_ToPrompt(UsingStr As String) - PRINT_ToPrompt(_System_GetUsingFormat(UsingStr)) -End Sub - -Macro LOCATE(x As Long, y As Long) +Sub Locate(x As Long, y As Long) If x < 0 Then x = 0 If y < 0 Then y = 0 @@ -653,15 +655,9 @@ _PromptSys_TextLine[y].Length = x End If -End Macro - - -'------------------- -' Graphics Commands -'------------------- - -Macro CIRCLE(x As Long , y As Long, radius As Long)(ColorCode As Long, StartPos As Double, EndPos As Double, Aspect As Double, bFill As Long, BrushColor As Long) - '呼び出し方法は以下のようになります（コンパイラがパラメータの並びを最適化します） - 'Circle (x, y), radius [, color] [, start] [, end] [, aspect] [, f] [, color2] - +End Sub + +'Prompt graphic command functions + +Sub Circle(x As Long , y As Long, radius As Long, ColorCode As Long, StartPos As Double, EndPos As Double, Aspect As Double, bFill As Long, BrushColor As Long) Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long @@ -763,9 +759,7 @@ DeleteObject(hPen) If bFill Then DeleteObject(hBrush) -End Macro - -Macro LINE(sx As Long, sy As Long, bStep As Long, ex As Long, ey As Long)(ColorCode As Long, fType As Long, BrushColor As Long) - '呼び出し方法は以下のようになります（コンパイラがパラメータの並びを最適化します） - 'Line (sx,sy)-[STEP](ex,ey),[ColorCode],[B/Bf],[BrushColor] +End Sub + +Sub Line(sx As Long, sy As Long, bStep As Long, ex As Long, ey As Long, ColorCode As Long, fType As Long, BrushColor As Long) Dim temp As Long @@ -796,5 +790,5 @@ End If - Dim hDC = GetDC(_PromptSys_hWnd) + Dim hdc = GetDC(_PromptSys_hWnd) Dim hPen = CreatePen(PS_SOLID, 1, GetBasicColor(ColorCode)) Dim hBrush As HBRUSH @@ -805,6 +799,6 @@ End If - SelectObject(hDC, hPen) - SelectObject(hDC, hBrush) + SelectObject(hdc, hPen) + SelectObject(hdc, hBrush) Dim hOldPen = SelectObject(_PromptSys_hMemDC, hPen) Dim hOldBrush = SelectObject(_PromptSys_hMemDC, hBrush) @@ -816,14 +810,14 @@ LineTo(_PromptSys_hMemDC,ex,ey) SetPixel(_PromptSys_hMemDC,ex,ey,GetBasicColor(ColorCode)) - MoveToEx(hDC,sx,sy,ByVal NULL) - LineTo(hDC,ex,ey) - SetPixel(hDC,ex,ey,GetBasicColor(ColorCode)) + MoveToEx(hdc,sx,sy,ByVal NULL) + LineTo(hdc,ex,ey) + SetPixel(hdc,ex,ey,GetBasicColor(ColorCode)) Case Else 'Rectangle - Rectangle(hDC,sx,sy,ex+1,ey+1) + Rectangle(hdc,sx,sy,ex+1,ey+1) Rectangle(_PromptSys_hMemDC,sx,sy,ex+1,ey+1) End Select - ReleaseDC(_PromptSys_hWnd,hDC) + ReleaseDC(_PromptSys_hWnd,hdc) SelectObject(_PromptSys_hMemDC,hOldPen) SelectObject(_PromptSys_hMemDC,hOldBrush) @@ -834,43 +828,32 @@ .y = ey End With -End Macro - -Macro PSET(x As Long, y As Long)(ColorCode As Long) - '呼び出し方法は以下のようになります（コンパイラがパラメータの並びを最適化します） - 'PSet (x,y),ColorCode - - Dim hDC = GetDC(_PromptSys_hWnd) - SetPixel(hDC, x, y, GetBasicColor(ColorCode)) +End Sub + +Sub PSet(x As Long, y As Long, ColorCode As Long) + Dim hdc = GetDC(_PromptSys_hWnd) + SetPixel(hdc, x, y, GetBasicColor(ColorCode)) SetPixel(_PromptSys_hMemDC, x, y, GetBasicColor(ColorCode)) - ReleaseDC(_PromptSys_hWnd, hDC) + ReleaseDC(_PromptSys_hWnd, hdc) With _PromptSys_GlobalPos .x = x .y = y End With -End Macro - -Macro PAINT(x As Long, y As Long, BrushColor As Long)(ByVal LineColor As Long) - '呼び出し方法は以下のようになります（コンパイラがパラメータの並びを最適化します） - 'Paint (x,y),BrushColor,LineColor - - Dim hBrush = CreateSolidBrush(GetBasicColor(BrushColor)) - - Dim hDC = GetDC(_PromptSys_hWnd) - Dim hOldBrush = SelectObject(_PromptSys_hMemDC, hBrush) - Dim hOldBrushWndDC = SelectObject(hDC, hBrush) - - ExtFloodFill(hDC, x, y, GetBasicColor(LineColor), FLOODFILLBORDER) +End Sub + +Sub Paint(x As Long, y As Long, BrushColor As Long, LineColor As Long) + Dim hbr = CreateSolidBrush(GetBasicColor(BrushColor)) + + Dim hdc = GetDC(_PromptSys_hWnd) + Dim hbrOld = SelectObject(_PromptSys_hMemDC, hbr) + Dim hbrOldWndDC = SelectObject(hdc, hbr) + + ExtFloodFill(hdc, x, y, GetBasicColor(LineColor), FLOODFILLBORDER) ExtFloodFill(_PromptSys_hMemDC, x, y, GetBasicColor(LineColor), FLOODFILLBORDER) - ReleaseDC(_PromptSys_hWnd, hDC) - SelectObject(_PromptSys_hMemDC, hOldBrush) - SelectObject(hDC, hOldBrushWndDC) - DeleteObject(hBrush) -End Macro - - -'----------- -' Functions -'----------- + ReleaseDC(_PromptSys_hWnd, hdc) + SelectObject(_PromptSys_hMemDC, hbrOld) + SelectObject(hdc, hbrOldWndDC) + DeleteObject(hbr) +End Sub Function Inkey$() As String @@ -884,5 +867,5 @@ Function Input$(length As Long) As String - Dim i As Long + Dim i = 0 As Long If length<=0 Then @@ -891,5 +874,4 @@ End If - i=0 While 1 If _PromptSys_KeyChar Then @@ -905,4 +887,88 @@ End Function +End Namespace 'Detail + +Function OwnerWnd() As HWND + Return Detail._PromptSys_hWnd +End Function + +End Namespace 'Prompt +End Namespace 'ActiveBasic + +'---------------------- +' Prompt text Commands +'---------------------- + +Sub PRINT_ToPrompt(s As String) + ActiveBasic.Prompt.Detail.PRINT_ToPrompt(s) +End Sub + +Macro CLS()(num As Long) + ActiveBasic.Prompt.Detail.Cls(num) +End Macro + +Macro COLOR(TextColorCode As Long)(BackColorCode As Long) + ActiveBasic.Prompt.Detail.Color(TextColorCode, BackColorCode) +End Macro + +'---------- Defined in "command.sbp" ---------- +'Dim _System_InputDataPtr[_System_MAX_PARMSNUM] As VoidPtr +'Dim _System_InputDataType[_System_MAX_PARMSNUM] As DWord +'---------------------------------------------- +Sub INPUT_FromPrompt(ShowStr As String) + ActiveBasic.Prompt.Detail.INPUT_FromPrompt(ShowStr) +End Sub + +Sub PRINTUSING_ToPrompt(UsingStr As String) + ActiveBasic.Prompt.Detail.PRINT_ToPrompt(_System_GetUsingFormat(UsingStr)) +End Sub + +Macro LOCATE(x As Long, y As Long) + ActiveBasic.Prompt.Detail.Locate(x, y) +End Macro + + +'------------------- +' Graphics Commands +'------------------- + +Macro CIRCLE(x As Long , y As Long, radius As Long)(ColorCode As Long, StartPos As Double, EndPos As Double, Aspect As Double, bFill As Long, BrushColor As Long) + '呼び出し方法は以下のようになります（コンパイラがパラメータの並びを最適化します） + 'Circle (x, y), radius [, color] [, start] [, end] [, aspect] [, f] [, color2] + ActiveBasic.Prompt.Detail.Circle(x, y, radius, ColorCode, StartPos, EndPos, Aspect, bFill, BrushColor) +End Macro + +Macro LINE(sx As Long, sy As Long, bStep As Long, ex As Long, ey As Long)(ColorCode As Long, fType As Long, BrushColor As Long) + '呼び出し方法は以下のようになります（コンパイラがパラメータの並びを最適化します） + 'Line (sx,sy)-[STEP](ex,ey),[ColorCode],[B/Bf],[BrushColor] + ActiveBasic.Prompt.Detail.Line(sx, sy, bStep, ex, ey, ColorCode, fType, BrushColor) +End Macro + +Macro PSET(x As Long, y As Long)(ColorCode As Long) + '呼び出し方法は以下のようになります（コンパイラがパラメータの並びを最適化します） + 'PSet (x,y),ColorCode + ActiveBasic.Prompt.Detail.PSet(x, y, ColorCode) +End Macro + +Macro PAINT(x As Long, y As Long, BrushColor As Long)(ByVal LineColor As Long) + '呼び出し方法は以下のようになります（コンパイラがパラメータの並びを最適化します） + 'Paint (x,y),BrushColor,LineColor + ActiveBasic.Prompt.Detail.Paint(x, y, BrushColor, LineColor) +End Macro + + +'----------- +' Functions +'----------- + +Function Inkey$() As String + Return ActiveBasic.Prompt.Detail.Inkey$() +End Function + +Function Input$(length As Long) As String + Return ActiveBasic.Prompt.Detail.Input$(length) +End Function + +ActiveBasic.Prompt.Detail._PromptSys_Initialize() #endif '_INC_PROMPT Index: Include/system/string.sbp =================================================================== --- Include/system/string.sbp (revision 257) +++ Include/system/string.sbp (revision 258) @@ -157,5 +157,5 @@ Function GetTCStr(s As String, ByRef tcs As PCTSTR) As SIZE_T - Return GetStr(s.Chars, s.Length As SIZE_T, wcs) + Return GetStr(s.Chars, s.Length As SIZE_T, tcs) End Function @@ -177,5 +177,5 @@ Function GetSCStr(s As String, ByRef ss As *StrChar) As SIZE_T - Return GetStr(s.Chars, s.Length As SIZE_T, wcs) + Return GetStr(s.Chars, s.Length As SIZE_T, ss) End Function