Страница: 1 2
Вопрос: Как решить данную проблему?
Добавлено: 14.03.10 18:14
Автор вопроса: Alex111
Доброе время суток.
Ответить
Номер ответа: 3Автор ответа: Alex111 Вопросов: 1Ответов: 13
Профиль | | #3
Добавлено: 14.03.10 20:16
Спасибо, но при этом мне нужна будет так описать 4 алфавита а эта не мало. Может есть другой способ по легче?
Ответить
Номер ответа: 5Автор ответа: Alex111 Вопросов: 1Ответов: 13
Профиль | | #5
Добавлено: 15.03.10 00:15
Winand
Ответить
Номер ответа: 6Автор ответа: Winand Вопросов: 87Ответов: 2795
Web-сайт: winandfx.narod.ru Профиль | | #6
Добавлено: 15.03.10 00:47
Ну я делал простой текстбокс в виде класса
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long )
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long , ByVal lHPalette As Long , ByRef lColorRef As Long ) As Long
Private Declare Function ShowWindow Lib "user32.dll" (ByVal hwnd As Long , ByVal nCmdShow As Long ) As Long
Dim m_Font As IFont
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long ) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32.dll" (ByRef lpLogBrush As LOGBRUSH) As Long
Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Private m_BackColor As Long
Private m_BackColorColor As Long
Private m_ForeColor As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long , ByRef lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32.dll" (ByVal hwnd As Long , ByRef lpRect As RECT) As Long
Private Declare Function SetBkColor Lib "gdi32.dll" (ByVal hdc As Long , ByVal crColor As Long ) As Long
Private Declare Function SetTextColor Lib "gdi32.dll" (ByVal hdc As Long , ByVal crColor As Long ) As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long , ByVal lpClassName As Long , _
ByVal lpWindowName As Long , ByVal dwStyle As Long , ByVal x As Long , ByVal y As Long , _
ByVal nWidth As Long , ByVal nHeight As Long , ByVal hWndParent As Long , _
ByVal hMenu As Long , ByVal hInstance As Long , lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32.dll" (ByVal hwnd As Long ) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongW" (ByVal hwnd As Long , ByVal nIndex As Long , ByVal dwNewLong As Long ) As Long
Private Const GWL_WNDPROC As Long = -4
Private Declare Function DefWindowProc Lib "user32.dll" Alias "DefWindowProcW" (ByVal hwnd As Long , ByVal wMsg As Long , ByVal wParam As Long , ByVal lParam As Long ) As Long
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcW" (ByVal lpPrevWndFunc As Long , ByVal hwnd As Long , ByVal msg As Long , ByVal wParam As Long , ByVal lParam As Long ) As Long
Private Const WS_EX_WINDOWEDGE As Long = &H100&
Private Const WS_EX_CLIENTEDGE As Long = &H200&
Private Const WS_EX_OVERLAPPEDWINDOW As Long = (WS_EX_WINDOWEDGE Or WS_EX_CLIENTEDGE)
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_CHILD As Long = &H40000000
Private Const ES_AUTOHSCROLL As Long = &H80&
Private Const ES_NOHIDESEL As Long = &H100&
Private Declare Function MoveWindow Lib "user32.dll" (ByVal hwnd As Long , ByVal x As Long , ByVal y As Long , ByVal nWidth As Long , ByVal nHeight As Long , ByVal bRepaint As Long ) As Long
Const AsmMain As String = "558BEC83C4FC8D45FC50FF7514FF7510FF750CFF75086800000000B800000000FFD08B45FCC9C21000"
Private ASMArr() As Byte
Private editproc As Long
Private editwnd As Long
Private prtproc As Long
Private prtwnd As Long
Private parent As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageW" (ByVal hwnd As Long , ByVal wMsg As Long , ByVal wParam As Long , lParam As Any) As Long
Private Const EM_LIMITTEXT As Long = &HC5
Private Const EM_SETSEL As Long = &HB1
Private Const EM_LINELENGTH As Long = &HC1
Private Const EM_GETLINE As Long = &HC4
Private Const WM_SETFONT As Long = &H30
Private Const WM_NCPAINT = &H85
Private Const WM_ERASEBKGND = &H14
Private Const WM_PAINT = &HF
Private Const WM_NCHITTEST = &H84
Private Const WM_SETCURSOR = &H20 Private Const WM_NCMOUSEMOVE = &HA0 Private Const WM_MOUSEMOVE = &H200
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_LBUTTONUP = &H202
Private Const WM_RBUTTONUP = &H205
Private Const WM_CHAR As Long = &H102
Private Const WM_SETFOCUS As Long = &H7
Private Const WM_KILLFOCUS As Long = &H8
Private Const WM_DESTROY As Long = &H2
Private Const WM_IME_SETCONTEXT As Long = &H281
Private Const WM_IME_NOTIFY As Long = &H282
Private Const WM_NCDESTROY As Long = &H82
Private Const WM_CTLCOLOREDIT As Long = &H133
Private Const WM_SETTEXT As Long = &HC
Private Const WM_COMMAND As Long = &H111
Private Const EN_CHANGE As Long = &H300
Public Event KeyDown(ByRef KeyCode As Long , ByRef lParam As Long )
Public Event KeyUp(ByRef KeyCode As Long , ByRef lParam As Long )
Public Event MouseDown(ByVal Button As Long )
Public Event MouseUp(ByVal Button As Long )
Public Event GotFocus()
Public Event Changed()
Public Function EditWindowProc(ByVal hwnd As Long , ByVal uMsg As Long , ByVal wParam As Long , ByVal lParam As Long ) As Long
Select Case uMsg
Case WM_SETFOCUS: RaiseEvent GotFocus
Case WM_KEYDOWN: RaiseEvent KeyDown(wParam, lParam)
Case WM_KEYUP: RaiseEvent KeyUp(wParam, lParam)
Case WM_LBUTTONDOWN: RaiseEvent MouseDown(vbLeftButton)
Case WM_RBUTTONDOWN: RaiseEvent MouseDown(vbRightButton)
Case WM_LBUTTONUP: RaiseEvent MouseUp(vbLeftButton)
Case WM_RBUTTONUP: RaiseEvent MouseUp(vbRightButton)
Case WM_CTLCOLOREDIT:
SetBkColor wParam, m_BackColorColor
SetTextColor wParam, m_ForeColor
EditWindowProc = m_BackColor
Exit Function
Case WM_COMMAND:
Select Case wParam \ &H10000
Case EN_CHANGE:
RaiseEvent Changed
End Select
Case WM_PAINT:
EditWindowProc = CallWindowProc(editproc, hwnd, uMsg, wParam, lParam)
EditWindowProc = DefWindowProc(hwnd, uMsg, wParam, lParam)
Exit Function
End Select
EditWindowProc = CallWindowProc(editproc, hwnd, uMsg, wParam, lParam)
End Function
Public Sub Move(Optional ByVal pLeft As Long = -1, Optional ByVal pTop As Long = -1, Optional ByVal pWidth As Long = -1, Optional ByVal pHeight As Long = -1)
Dim rc As RECT, rcp As RECT
GetWindowRect parent, rcp
GetWindowRect prtwnd, rc
MoveWindow prtwnd, IIf(pLeft <> -1, pLeft, rc.Left - rcp.Left), _
IIf(pTop <> -1, pTop, rc.Top - rcp.Top), _
IIf(pWidth <> -1, pWidth, rc.Right - rc.Left), _
IIf(pHeight <> -1, pHeight, rc.Bottom - rc.Top), 1
MoveWindow editwnd, 0, 0, _
IIf(pWidth <> -1, pWidth, rc.Right - rc.Left), _
IIf(pHeight <> -1, pHeight, rc.Bottom - rc.Top), 1
End Sub
Private Sub StartSubclass(ByRef ASM() As Byte , ByVal hwnd As Long , ByRef OldWndProc As Long , Optional ByVal ProcNumber As Long ) Dim lng As Long , tPtr As Long
lng = Len(AsmMain) \ 2&
ReDim ASM(0 To lng - 1)
For lng = 0 To lng - 1
ASM(lng) = Val("&H" & Mid$(AsmMain, (lng) * 2& + 1, 2&))
Next lng
Call CopyMemory(tPtr, ByVal ObjPtr(Me ), 4&)
Call CopyMemory(lng, ByVal tPtr + &H1C + (4& * ProcNumber), 4&)
Call CopyMemory(ASM(23), ObjPtr(Me), 4&)
Call CopyMemory(ASM(28), lng, 4&)
OldWndProc = SetWindowLong(hwnd, &HFFFC, VarPtr(ASM(0)))
End Sub
Private Sub StopSubclass(ByVal hwnd As Long , ByVal OldWndProc As Long )
Call SetWindowLong(hwnd, &HFFFC, OldWndProc)
End Sub
Public Sub init(ByVal hParent As Long , Optional ByVal pLeft As Long = 0, Optional ByVal pTop As Long = 0, Optional ByVal pWidth As Long = 200, Optional ByVal pHeight As Long = 20)
parent = hParent
prtwnd = CreateWindowEx(0, StrPtr("STATIC" ), StrPtr("" ), _
WS_VISIBLE Or WS_CHILD, _
pLeft, pTop, pWidth, pHeight, hParent, 0&, App.hInstance, ByVal 0&)
editwnd = CreateWindowEx(0, StrPtr("EDIT" ), StrPtr("" ), _
WS_VISIBLE Or WS_CHILD Or ES_AUTOHSCROLL Or ES_NOHIDESEL, _
0, 0, pWidth, pHeight, prtwnd, 0, App.hInstance, ByVal 0&)
Call StartSubclass(ASMArr, prtwnd, prtproc)
Call StartSubclass(ASMArr, editwnd, editproc)
Dim c1 As Long , c2 As Long
If OleTranslateColor(vbWindowBackground, 0, c1) Then BackColor = vbBlack Else BackColor = c1
If OleTranslateColor(vbWindowText, 0, c2) Then ForeColor = vbWhite Else ForeColor = c2
Set m_Font = New StdFont
m_Font.Name = "Verdana"
SendMessage editwnd, WM_SETFONT, m_Font.hFont, ByVal 1
End Sub
Private Sub Class_Terminate()
If editproc Then Call StopSubclass(editwnd, editproc): editproc = 0
If prtproc Then Call StopSubclass(prtwnd, editproc): prtproc = 0
DestroyWindow editwnd
DestroyWindow prtwnd
DeleteObject m_BackColor
DeleteObject m_ForeColor
Call m_Font.ReleaseHfont(m_Font.hFont)
End Sub
Public Sub SelectText(Optional ByVal pStart As Long = 0, Optional ByVal pFinish As Long = -1)
SendMessage editwnd, EM_SETSEL, 0, ByVal -1
End Sub
Public Property Let TextLimit(ByVal maxlen As Long )
SendMessage editwnd, EM_LIMITTEXT, maxlen, ByVal 0
End Property
Public Property Let Font(ByVal fontname As String )
m_Font.Name = fontname
SendMessage editwnd, WM_SETFONT, m_Font.hFont, ByVal 1
End Property
Public Property Get Length() As Long
Length = SendMessage(editwnd, EM_LINELENGTH, 0, ByVal 0)
End Property
Public Property Get Text() As String
Dim textlen As Long , copied As Long
If b(textlen, Length) Then
ReDim buf(textlen * 2 - 1) As Byte
lngToArr buf, textlen, 0
copied = SendMessage(editwnd, EM_GETLINE, 0, buf(0))
Text = MidB(buf, 1, copied * 2)
End If
End Property
Public Property Let Text(ByRef txt As String )
Call SendMessage(editwnd, WM_SETTEXT, 0, ByVal StrPtr(txt))
End Property
Public Property Get Width() As Long
Dim rc As RECT
GetWindowRect editwnd, rc
Width = rc.Right - rc.Left
End Property
Public Property Get Height() As Long
Dim rc As RECT
GetWindowRect editwnd, rc
Height = rc.Bottom - rc.Top
End Property
Public Property Get Left() As Long
Dim rc As RECT, rcp As RECT
GetWindowRect parent, rcp
GetWindowRect prtwnd, rc
Left = rc.Left - rcp.Left
End Property
Public Property Get Top() As Long
Dim rc As RECT, rcp As RECT
GetWindowRect parent, rcp
GetWindowRect prtwnd, rc
Top = rc.Top - rcp.Top
End Property
Public Property Let BackColor(ByVal Color As Long )
Dim lb As LOGBRUSH
lb.lbColor = Color
lb.lbStyle = 0
lb.lbHatch = 0
m_BackColor = CreateBrushIndirect(lb)
m_BackColorColor = Color
End Property
Public Property Let ForeColor(ByVal Color As Long )
m_ForeColor = Color
End Property
Public Property Let Visible(ByVal bool As Boolean )
Const SW_SHOW = &H5
Const SW_HIDE = &H0
ShowWindow prtwnd, IIf(bool , SW_SHOW, SW_HIDE)
End Property
Option Explicit
Public WithEvents TxtEdit As clsTextEdit
Private Sub Form_Load()
Set TxtEdit = New clsTextEdit
TxtEdit.init hwnd, 10, 10, 200, 20
End Sub Ответить
Номер ответа: 7Автор ответа: Alex111 Вопросов: 1Ответов: 13
Профиль | | #7
Добавлено: 15.03.10 01:22
Winand
Ответить
Номер ответа: 9Автор ответа: Alex111 Вопросов: 1Ответов: 13
Профиль | | #9
Добавлено: 15.03.10 20:41
Winand
Ответить
Номер ответа: 11Автор ответа: Alex111 Вопросов: 1Ответов: 13
Профиль | | #11
Добавлено: 15.03.10 22:27
Вот здесь Public Property Get Text() As String
Dim textlen As Long , copied As Long
If b(textlen, Length) Then
ReDim buf(textlen * 2 - 1) As Byte
lngToArr buf, textlen, 0
copied = SendMessage(editwnd, EM_GETLINE, 0, buf(0))
Text = MidB(buf, 1, copied * 2)
End If
End Property Ответить
Номер ответа: 13Автор ответа: Alex111 Вопросов: 1Ответов: 13
Профиль | | #13
Добавлено: 15.03.10 23:16
Так мне что ту часть кода заменить на то что ты сейчас написал? Да и вопрос а если я создам ЕХЕ то там при нажатие на крестик проблемы будут? или эта только в Бейзике так?
Ответить
Номер ответа: 15Автор ответа: Alex111 Вопросов: 1Ответов: 13
Профиль | | #15
Добавлено: 16.03.10 19:46
поставил в бейсики проблем нет, даже на Енд жать можно. А вот при создания ЕХЕ ругается опять но уже на другое вот здесь Public Property Get Text() As String
Dim textlen As Long , copied As Long
If b(textlen, Length) Then
ReDim buf(textlen * 2 - 1) As Byte
lngToArr buf, textlen, 0
copied = SendMessage(editwnd, EM_GETLINE, 0, buf(0))
Text = MidB(buf, 1, copied * 2)
End If
End Property TxtEdit.init hwnd, 10, 10, 200, 20 Ответить
Страница: 1 2
Поиск по форуму
Alex111
VbStarter
