Changeset 258 for Include/basic

Timestamp:

May 21, 2007, 1:03:21 AM (18 years ago)

Author:

イグトランス (egtra)

Message:

Prompt.sbp内を名前空間に入れた。EnvironmentのMachineName, UserName, GetFolderPathを実装。

Location:

Include/basic

Files:

• command.sbp (modified) (1 diff)
• function.sbp (modified) (1 diff)
• prompt.sbp (modified) (33 diffs)

Include/basic/command.sbp

@@ -34 +34 @@
 
 Sub _System_End()
-    Dim exitCode = Environment.ExitCode
+    Dim exitCode = System.Environment.ExitCode
     _System_EndProgram()
     ExitProcess(exitCode)

Include/basic/function.sbp

@@ -1231 +1231 @@
 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

Include/basic/prompt.sbp

@@ -5 +5 @@
 #define _INC_PROMPT
 
-
 #require <api_imm.sbp>
 #require <Classes/System/Math.ab>
-
+#require <Classes/System/Environment.ab>
+
+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 +54 @@
 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 +67 @@
 Dim _System_OSVersionInfo As OSVERSIONINFO
 
-_PromptSys_InputLen = -1
 
 'graphic
@@ -72 +74 @@
 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 +82 @@
 End If
 WaitForSingleObject(_PromptSys_hInitFinish, INFINITE)
+End Sub
 
 Sub DrawPromptBuffer(hDC As HDC, StartLine As Long, EndLine As Long)
@@ -267 +270 @@
     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 +290 @@
             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 +371 @@
 
         SendMessage(hwnd, WM_KILLFOCUS, 0, 0)
-        PRINT_ToPrompt(TempStr)
+        ActiveBasic.Prompt.Detail.PRINT_ToPrompt(TempStr)
         SendMessage(hwnd, WM_SETFOCUS, 0, 0)
     End If
@@ -372 +378 @@
 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 +388 @@
 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 +409 @@
         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 +428 @@
         _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 +461 @@
     End With
 
-    'LogFont initialize
-    With _PromptSys_LogFont
+    '_PromptSys_hFont initialize
+    Dim lf As LOGFONT
+    With lf
         .lfHeight = -16
         .lfWidth = 0
@@ -469 +477 @@
         .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 +495 @@
         .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 +502 @@
 
     '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 +511 @@
     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 +522 @@
 
     '強制的に終了する
-    End 'ExitProcess(0)
+    End
 
     EnterCriticalSection(_PromptSys_SectionOfBufferAccess)
@@ -522 +535 @@
     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 +560 @@
     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 +571 @@
     '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 +588 @@
 *InputReStart
 
-    PRINT_ToPrompt(ShowStr)
+    ActiveBasic.Prompt.Detail.PRINT_ToPrompt(showStr)
 
     'Input by keyboard
@@ -616 +622 @@
         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 +637 @@
 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 +655 @@
         _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 +759 @@
     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 +790 @@
     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 +799 @@
     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 +810 @@
             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 +828 @@
         .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 +867 @@
 
 Function Input$(length As Long) As String
-    Dim i As Long
+    Dim i = 0 As Long
 
     If length<=0 Then
@@ -891 +874 @@
     End If
 
-    i=0
     While 1
         If _PromptSys_KeyChar Then
@@ -905 +887 @@
 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