Changeset 126


Ignore:
Timestamp:
Mar 3, 2007, 5:53:34 PM (18 years ago)
Author:
イグトランス (egtra)
Message:

#68修正完了

Location:
Include/basic
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • Include/basic/function.sbp

    r125 r126  
    10681068End Function
    10691069
     1070Function _System_IsDoubleUnitChar(lead As Char, trail As Char) As Boolean
     1071#ifdef UNICODE
     1072    Return _System_IsSurrogatePair(lead, trail)
     1073#else
     1074    Return IsDBCSLeadByte(lead) <> FALSE
     1075#endif
     1076End Function
     1077
    10701078Sub _System_FillChar(p As *Char, n As SIZE_T, c As Char)
    10711079    Dim i As SIZE_T
     
    10831091End Function
    10841092
    1085 Function _System_ASCII_ToLower(c As Char)
     1093Function _System_ASCII_ToLower(c As Char) As Char
    10861094    If _System_ASCII_IsUpper(c) Then
    10871095        Return c Or &h20
     
    10911099End Function
    10921100
    1093 Function _System_ASCII_ToUpper(c As Char)
     1101Function _System_ASCII_ToUpper(c As Char) As Char
    10941102    If _System_ASCII_IsLower(c) Then
    10951103        Return c And (Not &h20)
  • Include/basic/prompt.sbp

    r125 r126  
    66
    77
    8 #include <api_imm.sbp>
     8#require <api_imm.sbp>
     9#require <Classes/System/Math.ab>
    910
    1011Dim _PromptSys_hWnd As HWND
     
    1314
    1415'text
     16Type _PromptSys_CharacterInformation
     17    ForeColor As COLORREF
     18    BackColor As COLORREF
     19    StartPos As Long
     20End Type
     21
     22Type _PromptSys_LineInformation
     23    Length As Long
     24    Text As *Char
     25    CharInfo As *_PromptSys_CharacterInformation
     26End Type
    1527
    1628Dim _PromptSys_LogFont As LOGFONTA 'LOGFONT
     
    2133Dim _PromptSys_KeyChar As Byte
    2234Dim _PromptSys_CurPos As POINTAPI
    23 Dim _PromptSys_Buffer[100] As *Char
    24 Dim _PromptSys_TextColor[100] As *COLORREF
    25 Dim _PromptSys_BackColor[100] As *COLORREF
    26 Dim _PromptSys_TextWidth[100] As Long
     35Dim _PromptSys_TextLine[100] As _PromptSys_LineInformation
    2736Dim _PromptSys_NowTextColor As COLORREF
    2837Dim _PromptSys_NowBackColor As COLORREF
     
    3039
    3140
    32 _PromptSys_InputLen=-1
     41_PromptSys_InputLen = -1
    3342
    3443'graphic
     
    3847Dim _PromptSys_GlobalPos As POINTAPI
    3948
    40 
    41 _PromptSys_bInitFinish=0
     49CreateEvent(0, FALSE, FALSE, 0)
     50_PromptSys_bInitFinish = 0
    4251CreateThread(0, 0, AddressOf(PromptMain) As LPTHREAD_START_ROUTINE, 0, 0, _PromptSys_dwThreadID)
    4352Do
     
    5463    GetClientRect(_PromptSys_hWnd, rc)
    5564    While (_PromptSys_CurPos.y+1) * _PromptSys_FontSize.cy > rc.bottom and _PromptSys_CurPos.y > 0
    56         _System_free(_PromptSys_Buffer[0])
    57         _System_free(_PromptSys_TextColor[0])
    58         _System_free(_PromptSys_BackColor[0])
     65        _System_free(_PromptSys_TextLine[0].Text)
     66        _System_free(_PromptSys_TextLine[0].CharInfo)
    5967        For i = 0 To 100 - 1
    60             _PromptSys_Buffer[i] = _PromptSys_Buffer[i+1]
    61             _PromptSys_TextColor[i] = _PromptSys_TextColor[i+1]
    62             _PromptSys_BackColor[i] = _PromptSys_BackColor[i+1]
    63             _PromptSys_TextWidth[i] = _PromptSys_TextWidth[i+1]
     68            _PromptSys_TextLine[i].Length = _PromptSys_TextLine[i+1].Length
     69            _PromptSys_TextLine[i].Text = _PromptSys_TextLine[i+1].Text
     70            _PromptSys_TextLine[i].CharInfo = _PromptSys_TextLine[i+1].CharInfo
    6471        Next
    65         _PromptSys_Buffer[100] = _System_calloc(SizeOf (Char) * 255)
    66         _PromptSys_TextColor[100] = _System_calloc(SizeOf(COLORREF) * 255)
    67         _PromptSys_BackColor[100] = _System_calloc(SizeOf(COLORREF) * 255)
    68         _PromptSys_TextWidth[100] = 0
    69 
     72        _PromptSys_TextLine[100].Length = 0
     73        _PromptSys_TextLine[100].Text = _System_calloc(SizeOf (Char) * 255)
     74        _PromptSys_TextLine[100].CharInfo = _System_calloc(SizeOf (_PromptSys_CharacterInformation) * 255)
    7075        _PromptSys_CurPos.y--
    7176
     
    7479    Wend
    7580
    76     i = 0
     81    i = 0' : Debug
    7782    While i * _PromptSys_FontSize.cy < rc.bottom and i <= 100
    7883        If StartLine=-1 or (StartLine<=i and i<=EndLine) Then
     84            Dim currentLineCharInfo = _PromptSys_TextLine[i].CharInfo
     85
    7986            Dim sz As SIZE
    80             i3 = lstrlen(_PromptSys_Buffer[i])
    81             GetTextExtentPoint32(hDC, _PromptSys_Buffer[i], i3, sz)
     87            i3 = lstrlen(_PromptSys_TextLine[i].Text) '_PromptSys_TextLine[i].Length
     88            If i3 <> 0 Then
     89                OutputDebugString(Str$(i3) + ":" + Str$(_PromptSys_TextLine[i].Length) + Ex"\r\n")
     90            End If
     91            GetTextExtentPoint32(hDC, _PromptSys_TextLine[i].Text, i3, sz)
    8292
    8393            BitBlt(hDC,_
     
    8696                _PromptSys_hMemDC, sz.cx, i * _PromptSys_FontSize.cy, SRCCOPY)
    8797
    88             Dim width = 0 As Long
    89             For i2 = 0 To i3-1
    90                 SetTextColor(hDC, _PromptSys_TextColor[i][i2])
    91                 If _PromptSys_BackColor[i][i2] = -1 Then
     98            While i2 < i3
     99                SetTextColor(hDC, currentLineCharInfo[i2].ForeColor)
     100                If currentLineCharInfo[i2].BackColor = -1 Then
    92101                    SetBkMode(hDC, TRANSPARENT)
    93102                Else
    94103                    SetBkMode(hDC, OPAQUE)
    95                     SetBkColor(hDC, _PromptSys_BackColor[i][i2])
     104                    SetBkColor(hDC, currentLineCharInfo[i2].BackColor)
    96105                End If
    97106
    98                 Dim temporary[2] As Char
    99107                Dim tempLen As Long
    100                 temporary[0] = _PromptSys_Buffer[i][i2]
    101 #ifdef UNICODE
    102                 If _System_IsSurrogatePair(_PromptSys_Buffer[i][i2], _PromptSys_Buffer[i][i2+1]) Then
    103 #else
    104                 If IsDBCSLeadByte(temporary[0]) Then
    105 #endif
    106                     temporary[1] = _PromptSys_Buffer[i][i2+1]
    107                     temporary[2] = 0
    108                     i2++
     108                If _System_IsDoubleUnitChar(_PromptSys_TextLine[i].Text[i2], _PromptSys_TextLine[i].Text[i2+1]) Then
    109109                    tempLen = 2
    110110                Else
    111                     temporary[1] = 0
    112111                    tempLen = 1
    113112                End If
    114113                With _PromptSys_FontSize
    115                     TextOut(hDC, width, i * .cy, temporary, tempLen)
     114                    TextOut(hDC, currentLineCharInfo[i2].StartPos, i * .cy, VarPtr(_PromptSys_TextLine[i].Text[i2]), tempLen)
    116115                End With
    117                 GetTextExtentPoint32(hDC, temporary, i3, sz)
    118                 width += sz.cx
    119             Next
     116                i2 += tempLen
     117            Wend
    120118        End If
    121119
     
    129127    EnterCriticalSection(_PromptSys_SectionOfBufferAccess)
    130128    With _PromptSys_CurPos
    131         Dim StartLine As Long
    132         StartLine = .y
     129        Dim hdc = GetDC(_PromptSys_hWnd)
     130        Dim hOldFont = SelectObject(hdc, _PromptSys_hFont)
     131        Dim StartLine As Long : StartLine = .y
     132        Dim bufLen = buf.Length
     133        Dim doubleUnitChar = False As Boolean
    133134        'Addition
    134         Dim i2 = 0 As Long, i3 As Long
    135         Do
    136             If buf[i2] = 9 Then 'tab
    137                 i3 = 8 - (.x And 7) '(.x mod 8)
    138                 _System_FillChar(VarPtr(_PromptSys_Buffer[.y][.x]), i3, &h20) 'Asc(" ")
    139                 i2++
    140                 .x += i3
    141                 Continue
     135        Dim i2 = 0 As Long, i3 As Long' : Debug
     136        For i2 = 0 To ELM(bufLen)
     137            If buf[i2] = &h0d Then 'CR \r
     138                _PromptSys_TextLine[.y].Length = .x
     139                .x = 0
     140            ElseIf buf[i2] = &h0a Then 'LF \n
     141                _PromptSys_TextLine[.y].Length = Math.Max(_PromptSys_TextLine[.y].Length, .x)
     142                .y++
     143            Else
     144                Dim currentLineCharInfo = _PromptSys_TextLine[.y].CharInfo As *_PromptSys_CharacterInformation
     145                _PromptSys_TextLine[.y].Text[.x] = buf[i2]
     146                currentLineCharInfo[.x].ForeColor = _PromptSys_NowTextColor
     147                currentLineCharInfo[.x].BackColor = _PromptSys_NowBackColor
     148
     149                If buf[i2] = &h09 Then 'tab
     150                    Dim tabStop = _PromptSys_FontSize.cx * 8
     151                    currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos + _
     152                        tabStop - currentLineCharInfo[.x].StartPos Mod tabStop
     153                Else
     154                    If doubleUnitChar <> False Then
     155                        doubleUnitChar = False
     156                        currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos
     157                    Else
     158                        Dim sz As SIZE
     159                        Dim charLen As Long
     160                        If _System_IsDoubleUnitChar(buf[i2], buf[i2 + 1]) Then
     161                            charLen = 2
     162                            doubleUnitChar = True
     163                        Else
     164                            charLen = 1
     165                        EndIf
     166                        GetTextExtentPoint32(hdc, VarPtr(buf.Chars[i2]), charLen, sz)
     167                        currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos + sz.cx
     168/*
     169                        Dim buf[1023] As Char
     170                        wsprintf(buf, Ex"%d %d\r\n", currentLineCharInfo[.x + 1].StartPos, currentLineCharInfo[.x].StartPos + sz.cx)
     171                        OutputDebugString(buf)
     172*/
     173                    End If
     174                End If
     175                .x++
    142176            End If
    143 
    144             If buf[i2] = 13 and buf[i2+1] = 10 Then '\r\n
    145                 i2 += 2
    146                 .y++
    147                 .x = 0
    148                 Continue
    149             End If
    150 
    151             If buf[i2] = 0 Then Exit Do
    152             _PromptSys_Buffer[.y][.x] = buf[i2]
    153             _PromptSys_TextColor[.y][.x] = _PromptSys_NowTextColor
    154             _PromptSys_BackColor[.y][.x] = _PromptSys_NowBackColor
    155 
    156             i2++
    157             .x++
    158         Loop
     177        Next
     178        _PromptSys_TextLine[.y].Length = Math.Max(_PromptSys_TextLine[.y].Length, .x)
    159179
    160180        'Draw the text buffer added
    161         Dim hDC = GetDC(_PromptSys_hWnd)
    162         DrawPromptBuffer(hDC, StartLine, .y)
    163         ReleaseDC(_PromptSys_hWnd, hDC)
     181        DrawPromptBuffer(hdc, StartLine, .y)
     182        SelectObject(hdc, hOldFont)
     183        ReleaseDC(_PromptSys_hWnd, hdc)
    164184    End With
    165185    LeaveCriticalSection(_PromptSys_SectionOfBufferAccess)
     
    167187
    168188Function PromptProc(hWnd As HWND, message As DWord, wParam As WPARAM, lParam As LPARAM) As LRESULT
    169     Dim hIMC As HIMC
    170     Dim hDC As HDC
    171     Dim ps As PAINTSTRUCT
    172     Dim TempStr As String
    173     Dim CompForm As COMPOSITIONFORM
    174 
    175189    Select Case message
    176190        Case WM_CREATE
    177             hDC = GetDC(hWnd)
    178             With _PromptSys_ScreenSize
    179                 _PromptSys_hBitmap = CreateCompatibleBitmap(hDC, .cx, .cy)
    180             End With
    181             _PromptSys_hMemDC = CreateCompatibleDC(hDC)
    182             SelectObject(_PromptSys_hMemDC, _PromptSys_hBitmap)
    183 
    184             'Initialize for Win9x
    185             Dim hOldBrush = SelectObject(_PromptSys_hMemDC, GetStockObject(BLACK_BRUSH)) As HBRUSH
    186             With _PromptSys_ScreenSize
    187                 PatBlt(_PromptSys_hMemDC, 0, 0, .cx, .cy, PATCOPY)
    188             End With
    189             SelectObject(_PromptSys_hMemDC, hOldBrush)
    190 
    191             Dim tm As TEXTMETRIC
    192             Dim hOldFont = SelectObject(_PromptSys_hMemDC, _PromptSys_hFont) As HFONT
    193             GetTextExtentPoint32(_PromptSys_hMemDC, " " As PCTSTR, 1, _PromptSys_FontSize)
    194             GetTextMetrics(_PromptSys_hMemDC, tm)
    195             SelectObject(_PromptSys_hMemDC, hOldFont)
    196             _PromptSys_FontSize.cy = tm.tmHeight
    197 
    198             ReleaseDC(hWnd,hDC)
     191            Return _PromptWnd_OnCreate(hWnd, ByVal lParam As *CREATESTRUCT)
    199192        Case WM_PAINT
    200             hDC = BeginPaint(hWnd, ps)
    201 /*
    202             With _PromptSys_ScreenSize
    203                 BitBlt(hDC, 0, 0, .cx, .cy, _PromptSys_hMemDC, 0, 0, SRCCOPY)
    204 */
    205             With ps.rcPaint
    206                 BitBlt(hDC, .left, .top, .right - .left, .bottom - .top, _PromptSys_hMemDC, .left, .top, SRCCOPY)
    207             End With
    208             DrawPromptBuffer(hDC, -1, 0)
    209             EndPaint(hWnd, ps)
    210 
    211             _PromptSys_bInitFinish = TRUE
     193            _PromptWnd_OnPaint(hWnd)
    212194        Case WM_SETFOCUS
    213             If _PromptSys_InputLen<>-1 Then
    214                 hIMC = ImmGetContext(hWnd)
    215                 If hIMC Then
    216                     With CompForm
    217                         .dwStyle = CFS_POINT
    218                         .ptCurrentPos.x = _PromptSys_CurPos.x * _PromptSys_FontSize.cx
    219                         .ptCurrentPos.y = _PromptSys_CurPos.y * _PromptSys_FontSize.cy
    220                     End With
    221                     ImmSetCompositionWindow(hIMC, CompForm)
    222                     ImmSetCompositionFontA(hIMC, _PromptSys_LogFont)
    223                 End If
    224                 ImmReleaseContext(hWnd, hIMC)
    225 
    226                 CreateCaret(hWnd, NULL, 9, 6)
    227                 SetCaretPos(_PromptSys_CurPos.x*_PromptSys_FontSize.cx, _
    228                     (_PromptSys_CurPos.y+1)*_PromptSys_FontSize.cy-7)
    229                 ShowCaret(hWnd)
    230             End If
     195            _PromptWnd_OnSetFocus(hWnd, wParam As HWND)
    231196        Case WM_KILLFOCUS
    232             HideCaret(hWnd)
    233             DestroyCaret()
     197            _PromptWnd_OnKillForcus(hWnd, wParam As HWND)
    234198        Case WM_KEYDOWN
    235             If _PromptSys_InputLen=-1 Then
    236                 _PromptSys_KeyChar=wParam As Byte
    237             End If
     199            _PromptWnd_OnKeyDown(wParam As DWord, LOWORD(lParam) As DWord, HIWORD(lParam) As DWord)
    238200        Case WM_CHAR
    239             If _PromptSys_InputLen <> -1 Then
    240                 If wParam = VK_BACK Then
    241                     If _PromptSys_InputLen Then
    242                         _PromptSys_InputLen--
    243                         _PromptSys_InputStr[_PromptSys_InputLen] = 0
    244 
    245                         _PromptSys_CurPos.x--
    246                         _PromptSys_Buffer[_PromptSys_CurPos.y][_PromptSys_CurPos.x] = 0
    247                     End If
    248                 ElseIf wParam = VK_RETURN Then
    249                     _PromptSys_InputStr[_PromptSys_InputLen] = 0
    250                     _PromptSys_InputLen = -1
    251                     TempStr = Ex"\r\n"
    252                 ElseIf wParam = &H16 Then
    253                     'Paste Command(Use Clippboard)
    254                     OpenClipboard(hWnd)
    255                     Dim hGlobal = GetClipboardData(CF_TEXT) As HGLOBAL
    256                     If hGlobal = 0 Then Return 0
    257                     Dim pTemp = GlobalLock(hGlobal) As PCSTR
    258 #ifdef UNICODE 'A版ウィンドウプロシージャ用
    259                     Dim tempSizeA = lstrlenA(pTemp)
    260                     Dim tempSizeW = MultiByteToWideChar(CP_ACP, 0, pTemp, tempSizeA, 0, 0) + 1
    261                     TempStr = ZeroString(tempSizeW)
    262                     MultiByteToWideChar(CP_ACP, 0, pTemp, tempSizeA, StrPtr(TempStr), tempSizeW)
    263 #else
    264                     TempStr = ZeroString(lstrlen(pTemp) + 1)
    265                     lstrcpy(StrPtr(TempStr), pTemp)
    266 #endif
    267                     memcpy(VarPtr(_PromptSys_InputStr[_PromptSys_InputLen]), TempStr.Chars, SizeOf (Char) * TempStr.Length)
    268                     _PromptSys_InputLen += TempStr.Length
    269 
    270                     GlobalUnlock(hGlobal)
    271                     CloseClipboard()
    272                 Else
    273                     _PromptSys_InputStr[_PromptSys_InputLen] = wParam As Byte
    274                     _PromptSys_InputLen++
    275 
    276                     TempStr.ReSize(1)
    277                     TempStr[0] = wParam As Char
    278                 End If
    279 
    280                 SendMessage(hWnd, WM_KILLFOCUS, 0, 0)
    281                 PRINT_ToPrompt(TempStr)
    282                 SendMessage(hWnd, WM_SETFOCUS, 0, 0)
    283             End If
     201            _PromptWnd_OnChar(hWnd, wParam, lParam)
    284202        Case WM_IME_COMPOSITION
    285             Return _PromptSys_OnImeCompostion(hWnd, wParam, lParam)
     203            Return _PromptWnd_OnImeCompostion(hWnd, wParam, lParam)
    286204        Case WM_DESTROY
    287             DeleteDC(_PromptSys_hMemDC)
    288             DeleteObject(_PromptSys_hBitmap)
    289 
    290             PostQuitMessage(0)
     205            _PromptWnd_OnDestroy(hWnd)
    291206        Case Else
    292             PromptProc=DefWindowProc(hWnd,message,wParam,lParam)
     207            PromptProc = DefWindowProc(hWnd, message, wParam, lParam)
    293208            Exit Function
    294209    End Select
    295     PromptProc=0
     210    PromptProc = 0
    296211End Function
    297212
    298 Function _PromptSys_OnImeCompostion(hwnd As HWND, wp As WPARAM, lp As LPARAM) As LRESULT
     213Function _PromptWnd_OnCreate(hwnd As HWND, ByRef cs As CREATESTRUCT) As LRESULT
     214    Dim hdc = GetDC(hwnd)
     215    With _PromptSys_ScreenSize
     216        _PromptSys_hBitmap = CreateCompatibleBitmap(hdc, .cx, .cy)
     217    End With
     218    _PromptSys_hMemDC = CreateCompatibleDC(hdc)
     219    SelectObject(_PromptSys_hMemDC, _PromptSys_hBitmap)
     220
     221    'Initialize for Win9x
     222    Dim hOldBrush = SelectObject(_PromptSys_hMemDC, GetStockObject(BLACK_BRUSH)) As HBRUSH
     223    With _PromptSys_ScreenSize
     224        PatBlt(_PromptSys_hMemDC, 0, 0, .cx, .cy, PATCOPY)
     225    End With
     226    SelectObject(_PromptSys_hMemDC, hOldBrush)
     227
     228    Dim tm As TEXTMETRIC
     229    Dim hOldFont = SelectObject(_PromptSys_hMemDC, _PromptSys_hFont) As HFONT
     230    GetTextMetrics(_PromptSys_hMemDC, tm)
     231    SelectObject(_PromptSys_hMemDC, hOldFont)
     232    With _PromptSys_FontSize
     233        .cx = tm.tmAveCharWidth
     234        .cy = tm.tmHeight
     235    End With
     236
     237    ReleaseDC(hwnd, hdc)
     238
     239    _PromptWnd_OnCreate = 0
     240End Function
     241
     242Sub _PromptWnd_OnPaint(hwnd As HWND)
     243    Dim ps As PAINTSTRUCT
     244    Dim hdc = BeginPaint(hwnd, ps)
     245'   With _PromptSys_ScreenSize
     246'       BitBlt(hdc, 0, 0, .cx, .cy, _PromptSys_hMemDC, 0, 0, SRCCOPY)
     247    With ps.rcPaint
     248        BitBlt(hdc, .left, .top, .right - .left, .bottom - .top, _PromptSys_hMemDC, .left, .top, SRCCOPY)
     249    End With
     250    DrawPromptBuffer(hdc, -1, 0)
     251    EndPaint(hwnd, ps)
     252
     253    _PromptSys_bInitFinish = TRUE
     254End Sub
     255
     256Sub _PromptWnd_OnSetFocus(hwnd As HWND, hwndOldFocus As HWND)
     257    If _PromptSys_InputLen <> -1 Then
     258        Dim himc = ImmGetContext(hwnd)
     259        If himc Then
     260            Dim CompForm As COMPOSITIONFORM
     261            With CompForm
     262                .dwStyle = CFS_POINT
     263                .ptCurrentPos.x = _PromptSys_CurPos.x * _PromptSys_FontSize.cx
     264                .ptCurrentPos.y = _PromptSys_CurPos.y * _PromptSys_FontSize.cy
     265            End With
     266            ImmSetCompositionWindow(himc, CompForm)
     267            ImmSetCompositionFontA(himc, _PromptSys_LogFont)
     268        End If
     269        ImmReleaseContext(hwnd, himc)
     270
     271        CreateCaret(hwnd, 0, 9, 6)
     272        SetCaretPos(_PromptSys_CurPos.x * _PromptSys_FontSize.cx, (_PromptSys_CurPos.y + 1) * _PromptSys_FontSize.cy - 7)
     273        ShowCaret(hwnd)
     274    End If
     275End Sub
     276
     277Sub _PromptWnd_OnKillForcus(hwnd As HWND, hwndNewFocus As HWND)
     278    HideCaret(hwnd)
     279    DestroyCaret()
     280End Sub
     281
     282Sub _PromptWnd_OnKeyDown(vk As DWord, repeat As DWord, flags As DWord)
     283    If _PromptSys_InputLen = -1 Then
     284        _PromptSys_KeyChar = vk As Byte
     285    End If
     286End Sub
     287
     288Sub _PromptWnd_OnDestroy(hwnd As HWND)
     289    DeleteDC(_PromptSys_hMemDC)
     290    DeleteObject(_PromptSys_hBitmap)
     291
     292    PostQuitMessage(0)
     293End Sub
     294
     295Sub _PromptWnd_OnChar(hwnd As HWND, wParam As WPARAM, lParam As LPARAM)
     296    Dim TempStr As String
     297    If _PromptSys_InputLen <> -1 Then
     298        If wParam = VK_BACK Then
     299            If _PromptSys_InputLen Then
     300                _PromptSys_InputLen--
     301                _PromptSys_InputStr[_PromptSys_InputLen] = 0
     302
     303                _PromptSys_CurPos.x--
     304                With _PromptSys_CurPos
     305                    _PromptSys_TextLine[.y].Text[.x] = 0
     306                End With
     307            End If
     308        ElseIf wParam = VK_RETURN Then
     309            _PromptSys_InputStr[_PromptSys_InputLen] = 0
     310            _PromptSys_InputLen = -1
     311            TempStr = Ex"\r\n"
     312        ElseIf wParam = &H16 Then
     313            'Paste Command(Use Clippboard)
     314            OpenClipboard(hwnd)
     315            Dim hGlobal = GetClipboardData(CF_TEXT) As HGLOBAL
     316            If hGlobal = 0 Then Exit Sub
     317            Dim pTemp = GlobalLock(hGlobal) As PCSTR
     318#ifdef UNICODE 'A版ウィンドウプロシージャ用
     319            Dim tempSizeA = lstrlenA(pTemp)
     320            Dim tempSizeW = MultiByteToWideChar(CP_ACP, 0, pTemp, tempSizeA, 0, 0) + 1
     321            TempStr = ZeroString(tempSizeW)
     322            MultiByteToWideChar(CP_ACP, 0, pTemp, tempSizeA, StrPtr(TempStr), tempSizeW)
     323#else
     324            TempStr = ZeroString(lstrlen(pTemp) + 1)
     325            lstrcpy(StrPtr(TempStr), pTemp)
     326#endif
     327            memcpy(VarPtr(_PromptSys_InputStr[_PromptSys_InputLen]), TempStr.Chars, SizeOf (Char) * TempStr.Length)
     328            _PromptSys_InputLen += TempStr.Length
     329
     330            GlobalUnlock(hGlobal)
     331            CloseClipboard()
     332        Else
     333            _PromptSys_InputStr[_PromptSys_InputLen] = wParam As Byte
     334            _PromptSys_InputLen++
     335
     336            TempStr.ReSize(1)
     337            TempStr[0] = wParam As Char
     338        End If
     339
     340        SendMessage(hwnd, WM_KILLFOCUS, 0, 0)
     341        PRINT_ToPrompt(TempStr)
     342        SendMessage(hwnd, WM_SETFOCUS, 0, 0)
     343    End If
     344End Sub
     345
     346Function _PromptWnd_OnImeCompostion(hwnd As HWND, wp As WPARAM, lp As LPARAM) As LRESULT
    299347    If (lp And GCS_RESULTSTR) <> 0 Then
    300348        Dim himc = ImmGetContext(hwnd)
     
    322370        SendMessage(hwnd, WM_SETFOCUS, 0, 0)
    323371
    324         Return 0
     372        _PromptWnd_OnImeCompostion = 0
    325373    Else
    326         Return DefWindowProc(hwnd, WM_IME_COMPOSITION, wp, lp)
     374        _PromptWnd_OnImeCompostion = DefWindowProc(hwnd, WM_IME_COMPOSITION, wp, lp)
    327375    End If
    328376End Function
     
    332380
    333381    'Allocate
    334     For i=0 To 100
    335         _PromptSys_Buffer[i] = _System_calloc(SizeOf (Char) * 255)
    336         _PromptSys_TextColor[i] = _System_calloc(SizeOf(COLORREF) * 255)
    337         _PromptSys_BackColor[i] = _System_calloc(SizeOf(COLORREF) * 255)
     382    For i = 0 To 100
     383        With _PromptSys_TextLine[i]
     384            .Length = 0
     385            .Text = _System_calloc(SizeOf (Char) * 255)
     386            .CharInfo = _System_calloc(SizeOf (_PromptSys_CharacterInformation) * 255)
     387        End With
    338388    Next
    339389
    340390    'Current Colors initialize
    341     _PromptSys_NowTextColor=RGB(255,255,255)
    342     _PromptSys_NowBackColor=RGB(0,0,0)
     391    _PromptSys_NowTextColor = RGB(255, 255, 255)
     392    _PromptSys_NowBackColor = RGB(0, 0, 0)
    343393
    344394    'Setup
     
    370420    End With
    371421
    372     _PromptSys_hFont = CreateFontIndirectA(ByVal VarPtr(_PromptSys_LogFont))
     422    _PromptSys_hFont = CreateFontIndirectA(_PromptSys_LogFont)
    373423
    374424    'Critical Section
     
    381431        .cbSize = Len(wcl)
    382432        .hInstance = GetModuleHandle(0)
    383         .style = CS_HREDRAW or CS_VREDRAW' or CS_DBLCLKS
    384         .hIcon = LoadIcon(NULL, MAKEINTRESOURCE(IDI_APPLICATION))
    385         .hIconSm = LoadIcon(NULL, MAKEINTRESOURCE(IDI_WINLOGO))
    386         .hCursor = LoadCursor(NULL, MAKEINTRESOURCE(IDC_ARROW))
     433        .style = CS_HREDRAW Or CS_VREDRAW' or CS_DBLCLKS
     434        .hIcon = LoadImage(0, MAKEINTRESOURCE(IDI_APPLICATION), IMAGE_ICON, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HICON
     435        .hIconSm = LoadImage(0, MAKEINTRESOURCE(IDI_WINLOGO), IMAGE_ICON, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HICON
     436        .hCursor = LoadImage(0, MAKEINTRESOURCE(IDC_ARROW), IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HCURSOR
    387437        .lpszClassName = "PROMPT"
    388438        .lpfnWndProc = AddressOf(PromptProc)
     
    401451    Do
    402452        Dim iResult = GetMessage(msg, 0, 0, 0)
    403         If iResult = 0 or iResult = -1 Then Exit Do
     453        If iResult = 0 Or iResult = -1 Then Exit Do
    404454        TranslateMessage(msg)
    405455        DispatchMessage(msg)
     
    410460
    411461    EnterCriticalSection(_PromptSys_SectionOfBufferAccess)
    412    
    413     For i=0 to 100
    414         _System_free(_PromptSys_Buffer[i])
    415         _System_free(_PromptSys_TextColor[i])
    416         _System_free(_PromptSys_BackColor[i])
     462
     463    For i = 0 to 100
     464        _System_free(_PromptSys_TextLine[i].Text)
     465        _System_free(_PromptSys_TextLine[i].CharInfo)
    417466    Next
    418467
     
    431480Macro CLS()(num As Long)
    432481    Dim i As Long
    433     Dim hOldBrush As HBRUSH
    434482
    435483    'When parameter was omitted, num is set to 1
    436     If num=0 Then num=1
    437 
    438     If num=1 or num=3 Then
     484    If num = 0 Then num = 1
     485
     486    If num = 1 Or num = 3 Then
    439487        'Clear the text screen
    440488        For i = 0 To 100
    441             _System_FillChar(_PromptSys_Buffer[i],255,0)
     489            With _PromptSys_TextLine[i]
     490                .Text[0] = 0 '_System_FillChar(_PromptSys_TextLine[i].Text, -1 As Char, 0)
     491                .Length = 0
     492            End With
    442493        Next
    443494        With _PromptSys_CurPos
     
    447498    End If
    448499
    449     If num=2 or num=3 Then
     500    If num = 2 Or num = 3 Then
    450501        'Clear the graphics screen
    451         hOldBrush=SelectObject(_PromptSys_hMemDC,GetStockObject(BLACK_BRUSH))
    452         PatBlt(_PromptSys_hMemDC,0,0,_PromptSys_ScreenSize.cx,_PromptSys_ScreenSize.cy,PATCOPY)
    453         SelectObject(_PromptSys_hMemDC,hOldBrush)
     502        Dim hOldBrush = SelectObject(_PromptSys_hMemDC, GetStockObject(BLACK_BRUSH))
     503        With _PromptSys_ScreenSize
     504            PatBlt(_PromptSys_hMemDC, 0, 0, .cx, .cy, PATCOPY)
     505        End With
     506        SelectObject(_PromptSys_hMemDC, hOldBrush)
    454507    End If
    455508
    456509    'Redraw
    457     InvalidateRect(_PromptSys_hWnd,ByVal 0,0)
     510    InvalidateRect(_PromptSys_hWnd, ByVal 0, 0)
    458511End Macro
    459512
    460513Macro COLOR(TextColorCode As Long)(BackColorCode As Long)
    461     _PromptSys_NowTextColor=GetBasicColor(TextColorCode)
    462     If BackColorCode=-1 Then
    463         _PromptSys_NowBackColor=-1
     514    _PromptSys_NowTextColor = GetBasicColor(TextColorCode)
     515    If BackColorCode = -1 Then
     516        _PromptSys_NowBackColor = -1
    464517    Else
    465         _PromptSys_NowBackColor=GetBasicColor(BackColorCode)
     518        _PromptSys_NowBackColor = GetBasicColor(BackColorCode)
    466519    End If
    467520End Macro
     
    480533
    481534    'Input by keyboard
    482     _PromptSys_InputLen=0
    483     SendMessage(_PromptSys_hWnd,WM_SETFOCUS,0,0)
    484     While _PromptSys_InputLen<>-1
     535    _PromptSys_InputLen = 0
     536    SendMessage(_PromptSys_hWnd, WM_SETFOCUS, 0, 0)
     537    While _PromptSys_InputLen <> -1
    485538        Sleep(10)
    486539    Wend
    487     SendMessage(_PromptSys_hWnd,WM_KILLFOCUS,0,0)
     540    SendMessage(_PromptSys_hWnd, WM_KILLFOCUS, 0, 0)
    488541
    489542    'Set value to variable
     
    510563
    511564        i++
    512         If _System_InputDataPtr[i]=0 and _PromptSys_InputStr[i2]=&h2c Then 'Asc(",")
     565        If _System_InputDataPtr[i] = 0 and _PromptSys_InputStr[i2] = &h2c Then 'Asc(",")
    513566            PRINT_ToPrompt(Ex"入力データの個数が多すぎます\r\n")
    514567            Goto *InputReStart
    515         ElseIf _PromptSys_InputStr[i2]=0 Then
     568        ElseIf _PromptSys_InputStr[i2] = 0 Then
    516569            If _System_InputDataPtr[i]<>0 Then
    517570                PRINT_ToPrompt(Ex"入力データの個数が足りません\r\n")
     
    531584
    532585Macro LOCATE(x As Long, y As Long)
    533     Dim i As Long, i2 As Long
    534 
    535     If x<0 Then x=0
    536     If y<0 Then y=0
    537     If y>100 Then y=100
     586    If x < 0 Then x = 0
     587    If y < 0 Then y = 0
     588    If y > 100 Then y = 100
    538589    With _PromptSys_CurPos
    539590        .x = x
    540591        .y = y
    541592    End With
    542     i=0
    543     While _PromptSys_Buffer[y][i]
    544         i++
    545     Wend
    546 
     593
     594    Dim i = _PromptSys_TextLine[y].Length
    547595    If i < x Then
    548         _System_FillChar(VarPtr(_PromptSys_Buffer[y][i]), x - i, &h20) 'Asc(" ")
    549         For i2 = i To x - 1
    550             _PromptSys_BackColor[y][i2] = -1
     596        _System_FillChar(VarPtr(_PromptSys_TextLine[y].Text[i]), x - i, &h20) 'Asc(" ")
     597        Dim i2 As Long
     598        For i2 = i To ELM(x)
     599            _PromptSys_TextLine[y].CharInfo[i2].BackColor = -1
    551600        Next
     601        _PromptSys_TextLine[y].Length = x
    552602    End If
    553603End Macro
     
    562612    'Circle (x, y), radius [, color] [, start] [, end] [, aspect] [, f] [, color2]
    563613
     614    Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long
     615
     616    Dim hPen = CreatePen(PS_SOLID,1,GetBasicColor(ColorCode))
    564617    Dim hBrush As HBRUSH
     618    If bFill Then
     619        hBrush = CreateSolidBrush(GetBasicColor(BrushColor))
     620    Else
     621        hBrush = GetStockObject(NULL_BRUSH)
     622    End If
     623
     624    Dim hDC = GetDC(_PromptSys_hWnd)
     625    Dim hOldPenDC = SelectObject(hDC, hPen)
     626    Dim hOldBrushDC = SelectObject(hDC, hBrush)
     627    Dim hOldPen = SelectObject(_PromptSys_hMemDC, hPen)
     628    Dim hOldBrush = SelectObject(_PromptSys_hMemDC, hBrush)
     629
    565630    Dim radi2 As Long
    566     Dim sw As Long
    567     Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long
    568 
    569     Dim hPen = CreatePen(PS_SOLID,1,GetBasicColor(ColorCode))
    570     If bFill Then
    571         hBrush=CreateSolidBrush(GetBasicColor(BrushColor))
    572     Else
    573         hBrush=GetStockObject(NULL_BRUSH)
    574     End If
    575 
    576     Dim hDC=GetDC(_PromptSys_hWnd)
    577     SelectObject(hDC,hPen)
    578     SelectObject(hDC,hBrush)
    579     Dim hOldPen=SelectObject(_PromptSys_hMemDC,hPen)
    580     Dim hOldBrush=SelectObject(_PromptSys_hMemDC,hBrush)
    581 
    582631    If Aspect<1 Then
    583632        radi2=(CDbl(radius)*Aspect) As Long
     
    591640        Ellipse(_PromptSys_hMemDC,x-radius,y-radi2,x+radius,y+radi2)
    592641    Else
     642        Dim sw As Long
    593643        StartPos *=StartPos
    594644        EndPos *=EndPos
     
    654704    End If
    655705
    656     ReleaseDC(_PromptSys_hWnd,hDC)
    657     SelectObject(_PromptSys_hMemDC,hOldPen)
    658     SelectObject(_PromptSys_hMemDC,hOldBrush)
     706    SelectObject(hDC, hOldPenDC)
     707    SelectObject(hDC, hOldBrushDC)
     708    ReleaseDC(_PromptSys_hWnd, hDC)
     709    SelectObject(_PromptSys_hMemDC, hOldPen)
     710    SelectObject(_PromptSys_hMemDC, hOldBrush)
    659711    DeleteObject(hPen)
    660712    If bFill Then DeleteObject(hBrush)
     
    666718    Dim temp As Long
    667719
    668     If sx=&H80000000 And sy=&H80000000 Then
    669         sx=_PromptSys_GlobalPos.x
    670         sy=_PromptSys_GlobalPos.y
     720    If sx = &H80000000 And sy = &H80000000 Then
     721        With _PromptSys_GlobalPos
     722            sx = .x
     723            sy = .y
     724        End With
    671725    End If
    672726
     
    694748    Dim hBrush As HBRUSH
    695749    If fType=2 Then
    696         hBrush=CreateSolidBrush(GetBasicColor(BrushColor))
     750        hBrush = CreateSolidBrush(GetBasicColor(BrushColor))
    697751    Else
    698         hBrush=GetStockObject(NULL_BRUSH)
    699     End If
    700 
    701     SelectObject(hDC,hPen)
    702     SelectObject(hDC,hBrush)
    703     Dim hOldPen = SelectObject(_PromptSys_hMemDC,hPen)
    704     Dim hOldBrush = SelectObject(_PromptSys_hMemDC,hBrush)
     752        hBrush = GetStockObject(NULL_BRUSH)
     753    End If
     754
     755    SelectObject(hDC, hPen)
     756    SelectObject(hDC, hBrush)
     757    Dim hOldPen = SelectObject(_PromptSys_hMemDC, hPen)
     758    Dim hOldBrush = SelectObject(_PromptSys_hMemDC, hBrush)
    705759
    706760    Select Case fType
     
    723777    SelectObject(_PromptSys_hMemDC,hOldBrush)
    724778    DeleteObject(hPen)
    725     If fType=2 Then DeleteObject(hBrush)
    726 
    727     _PromptSys_GlobalPos.x=ex
    728     _PromptSys_GlobalPos.y=ey
     779    If fType = 2 Then DeleteObject(hBrush)
     780    With _PromptSys_GlobalPos
     781        .x = ex
     782        .y = ey
     783    End With
    729784End Macro
    730785
     
    733788    'PSet (x,y),ColorCode
    734789
    735     Dim hDC=GetDC(_PromptSys_hWnd)
    736     SetPixel(hDC,x,y,GetBasicColor(ColorCode))
    737     SetPixel(_PromptSys_hMemDC,x,y,GetBasicColor(ColorCode))
    738     ReleaseDC(_PromptSys_hWnd,hDC)
    739 
    740     _PromptSys_GlobalPos.x=x
    741     _PromptSys_GlobalPos.y=y
     790    Dim hDC = GetDC(_PromptSys_hWnd)
     791    SetPixel(hDC, x, y, GetBasicColor(ColorCode))
     792    SetPixel(_PromptSys_hMemDC, x, y, GetBasicColor(ColorCode))
     793    ReleaseDC(_PromptSys_hWnd, hDC)
     794    With _PromptSys_GlobalPos
     795        .x = x
     796        .y = y
     797    End With
    742798End Macro
    743799
     
    746802    'Paint (x,y),BrushColor,LineColor
    747803
    748     Dim hDC As HDC
    749     Dim hBrush As HBRUSH, hOldBrush As VoidPtr
    750    
    751     hBrush=CreateSolidBrush(GetBasicColor(BrushColor))
    752 
    753     hDC=GetDC(_PromptSys_hWnd)
    754     SelectObject(hDC,hBrush)
    755     hOldBrush=SelectObject(_PromptSys_hMemDC,hBrush)
    756 
    757     ExtFloodFill(hDC,x,y,GetBasicColor(LineColor),FLOODFILLBORDER)
    758     ExtFloodFill(_PromptSys_hMemDC,x,y,GetBasicColor(LineColor),FLOODFILLBORDER)
    759 
    760     ReleaseDC(_PromptSys_hWnd,hDC)
    761     SelectObject(_PromptSys_hMemDC,hOldBrush)
     804    Dim hBrush = CreateSolidBrush(GetBasicColor(BrushColor))
     805
     806    Dim hDC = GetDC(_PromptSys_hWnd)
     807    Dim hOldBrush = SelectObject(_PromptSys_hMemDC, hBrush)
     808    Dim hOldBrushWndDC = SelectObject(hDC, hBrush)
     809
     810    ExtFloodFill(hDC, x, y, GetBasicColor(LineColor), FLOODFILLBORDER)
     811    ExtFloodFill(_PromptSys_hMemDC, x, y, GetBasicColor(LineColor), FLOODFILLBORDER)
     812
     813    ReleaseDC(_PromptSys_hWnd, hDC)
     814    SelectObject(_PromptSys_hMemDC, hOldBrush)
     815    SelectObject(hDC, hOldBrushWndDC)
    762816    DeleteObject(hBrush)
    763817End Macro
     
    791845            _PromptSys_KeyChar=0
    792846            i++
    793             If i>=length Then
     847            If i >= length Then
    794848                Exit While
    795849            End If
Note: See TracChangeset for help on using the changeset viewer.