da ist kein Return Event, kein Drag nur Drop, mangelhafte Eingabekontrolle
Hier ein Basismodul welches aus einem Editorgadget ein Stringgadget macht incl. ein EventType() für Return
Ich nenne es InputGadget. Das Modul liefert in dieser Form nur die Basis Routinen, nur zwei Flags + keine Eingabekontrolle
Bei den Flags des Stringadgets kommt es teilweise zu unerwünschten Ereignissen in Verbindung mit dem Editorgadget.
Das kann man aber in künftigen Erweiterungen abstellen. Eingabekontrollen sind doch sehr speziell, selbst numerische
Eingaben sind von User zu User und von Land zu Land unterschiedlich. Aber alles machbar.
Wie man ein PopUpMenu innerhalb eines Moduls am Besten erstellt ist mir aber ohne PB_any in Verbindung mit MenuItem() nicht ganz klar.
Über entsprechende Vorschläge würde ich mich freuen.
Mein Dank auch an User CHI für sein Beispiel "EditorGadget Border Color ändern ?", welches ich als Inspiration benutzt habe.
Da es zur Verwirklichung dieses Moduls ohne API nicht geht nur für Windows ab 10 getestet mit PB 5.70 x86 PB 5.72 x64
Wer sich für die Control Codes interessiert F1 drücken, die meisten funktionieren aber nicht alle.
Das mit dem internen PopUpMenu ist mir nun doch zu unflexibel. Darum gibt es nun ein EventType() #PB_EventType_RightClick
und ein jeder kann sich das PopUp im Mainprogramm selber erstellen und anzeigen
Code: Alles auswählen
;HJBremer
;InputGadget 2.22 - 02.Apr.2023 - ab PB 5.70 x86, 5.72 x64, Windows 10 - basiert auf dem EditorGadget
;Flags: #PB_String_Password (32), #PB_String_ReadOnly (2048)
;Eventtypes: #PB_EventType_Change, #PB_EventType_Focus, #PB_EventType_LostFocus
;zusätzlich gibt es #PB_EventType_ReturnKey, wenn Return gedrückt wurde
;zusätzlich gibt es #PB_EventType_RightClick, für rechte Maustaste z.B. für ein PopUpMenu
;Leftclick am rechten Rand löscht Text, Rightclick wieder einsetzen
;da Editorgadget, funktioniert Drag/Drop automatisch
;F1 ruft Liste der Ctrl Codes auf (https://learn.microsoft.com ...)
;gibt es AddKeyboardShortcut(#mainwindow, #PB_Shortcut_Return, #xxx), funktioniert Return nicht
;TODO Uppercase, Lowercase, Numeric, Select
DeclareModule InputGadget
Declare.i InputGadget(pbnr, x, y, w, h, text$, flag=0)
#PB_EventType_ReturnKey = 1281 ;ab 5.72 nicht mehr in PB vorhanden
EndDeclareModule
Module InputGadget
;XIncludeFile "..\inc\translatemsg.pbi"
EnableExplicit
Global cursorhand = LoadCursor_(0,#IDC_HAND) ;HandCursor wenn am rechten Rand
Global rwidth = 10 ;breite für rechten Rand um anderen Cursor anzuzeigen für löschen
Global backcolor = $aFFFFF ;BackColor wenn Focus
Global bordercolor = $EEB200 ;Rahmenfarbe hellblau
Global bordernormal = #Gray ;Rahmenfarbe Standard
#inputgadgetproptext = "#inputgadgetproptext" ;PropString um auf Gadgetdaten zuzugreifen
#mscc = "https://learn.microsoft.com/en-us/windows/win32/controls/about-rich-edit-controls#rich-edit-shortcut-keys"
Structure InputGadget
id.i ;GadgetId()
pbnr.i ;Purebasic Nr
flags.i ;Future
oldtext.s ;wenn gelöscht nach oldtext
oldwndprc.i ;zeiger auf OriginalCallback
backcolor.i ;BackColor wenn Focus
EndStructure
;-
Macro Gadget_Find(hwnd)
hwnd = FindWindowEx_(parent, hwnd, 0,0)
pbnr = GetDlgCtrlID_(hwnd)
If IsGadget(pbnr)
If GadgetType(pbnr) = #PB_GadgetType_Editor
SetActiveGadget(pbnr): Break
EndIf
EndIf
EndMacro
Procedure.i InputGadget_Next(hwnd)
;sucht das nächste Editor-InputGadget
Protected pbnr, parent = GetParent_(hwnd)
Repeat
Gadget_Find(hwnd)
If hwnd = 0: Gadget_Find(hwnd): EndIf
Until hwnd = 0
EndProcedure
Procedure.i InputGadget_Border(hwnd, color)
;Rahmen andere Farbe (in Windows 10)
Protected rc.RECT, hdc = GetWindowDC_(hwnd)
Protected hbrush = CreateSolidBrush_(color)
Protected oldbrush = SelectObject_(hdc, hbrush)
GetWindowRect_(hWnd, rc): OffsetRect_(rc, -rc\left, -rc\top) ;Gadgetgröße
FrameRect_(hdc, rc, hbrush)
SelectObject_(hdc, oldbrush): DeleteObject_(hbrush): ReleaseDC_(hwnd, hdc)
EndProcedure
Procedure.i InputGadget_Vertical(hwnd, font, y=0)
Protected dc = GetDC_(hwnd), s.Size, r.Rect
SelectObject_(dc, font)
GetTextExtentPoint32_(dc,"ABC", 3, s)
ReleaseDC_(hwnd, dc)
GetClientRect_(hwnd, r)
SendMessage_(hwnd, #EM_GETRECT, 0, r)
r\top = ((r\bottom - s\cy + y) / 2)
SendMessage_(hwnd,#EM_SETRECT, 0, r)
EndProcedure
Procedure.i InputGadget_CallBack(hwnd, msg, wparam, lparam)
Protected *data.InputGadget = GetProp_(hwnd, #inputgadgetproptext)
Protected oldwndproc = *data\oldwndprc ; muß sein wegen FreeStructure
Protected text$, mousex, gwidth = GadgetWidth(*data\pbnr)
Static oldcursor
With *data
Select msg
Case #WM_HELP: RunProgram(#mscc): ProcedureReturn 0
Case #WM_NCDESTROY: RemoveProp_(hwnd, #inputgadgetproptext): FreeStructure(*data)
Case #WM_SETFOCUS
SendMessage_(\id, #EM_SETSEL, $FFFF, $FFFF) ;Caret immer am Textende
\backcolor = GetGadgetColor(\pbnr, #PB_Gadget_BackColor)
SetGadgetColor(\pbnr, #PB_Gadget_BackColor, backcolor)
InputGadget_Border(hwnd, bordercolor) ;Rahmen andere Farbe
Case #WM_KILLFOCUS
SetGadgetColor(\pbnr, #PB_Gadget_BackColor, \backcolor)
InputGadget_Border(hwnd, bordernormal)
Case #WM_MOUSEFIRST
mousex = lparam & $FFFF ;LoWord von lParam
If mousex > gwidth - rwidth ;wenn Maus am Rand Cursor ändern
oldcursor = SetCursor_(cursorhand)
Else
If oldcursor ;sonst normaler Cursor
SetCursor_(oldcursor): oldcursor = 0
EndIf
EndIf
Case #WM_SETCURSOR
If oldcursor: ProcedureReturn 0: EndIf ;damit Cursor nicht flackert
Case #WM_LBUTTONDOWN ;Leftclick am Rand = Text löschen
mousex = lparam & $FFFF
If mousex > gwidth - rwidth ;wenn Mausclick am Rand
text$ = GetGadgetText(\pbnr)
If text$
\oldtext = text$ ;Text speichern
SetGadgetText(\pbnr, "") ;Text löschen
EndIf
EndIf
Case #WM_RBUTTONDOWN
mousex = lparam & $FFFF
If mousex > gwidth - rwidth ;wenn Mausclick am Rand
If \oldtext ;oldtext einsetzen wenn vorhanden
SetGadgetText(\pbnr, \oldtext)
SendMessage_(\id, #EM_SETSEL, $FFFF, $FFFF) ;Cursor ans Textende
EndIf
Else
PostEvent(#PB_Event_Gadget, EventWindow(), \pbnr, #PB_EventType_RightClick)
EndIf
Case #WM_KEYDOWN
If wparam = 13 ;Return muß hier abgefangen werden, sonst neue Zeile
wparam = 0 : InputGadget_Next(hwnd)
PostEvent(#PB_Event_Gadget, EventWindow(), \pbnr, #PB_EventType_ReturnKey)
EndIf
Case #WM_CHAR: ;Debug wparam
Select wparam
Case 8 ;tue nix
Case 9 ;TAB = 9 muß hier abgefangen werden, weil Editorgadget
wparam = 0 : SetFocus_(GetWindow_(hWnd, #GW_HWNDNEXT))
EndSelect
Case #WM_SETFONT: InputGadget_Vertical(hwnd, wparam)
Case #WM_CONTEXTMENU:
Default: ;Debug \pbnr: TranslateMsgWM(msg): Debug "-----"
EndSelect
EndWith
ProcedureReturn CallWindowProc_(oldwndproc, hwnd, msg, wparam, lparam)
EndProcedure
;-
Procedure.i InputGadget(pbnr, x, y, w, h, text$, flags=0)
Protected id, nr, *data.InputGadget = AllocateStructure(InputGadget)
nr = EditorGadget(pbnr, x, y, w, h, flags)
If pbnr = #PB_Any : pbnr = nr: id = GadgetID(nr) : Else : id = nr : EndIf
SetGadgetText(pbnr, text$)
*data\id = id
*data\pbnr = pbnr
*data\oldwndprc = SetWindowLongPtr_(id, #GWL_WNDPROC, @InputGadget_CallBack())
SetProp_(id, #inputgadgetproptext, *data)
SendMessage_(id, #EM_SHOWSCROLLBAR, #SB_HORZ, #False)
SendMessage_(id, #EM_SHOWSCROLLBAR, #SB_VERT, #False)
SendMessage_(id, #EM_SETMARGINS, #EC_LEFTMARGIN, 5)
SendMessage_(id, #EM_SETMARGINS, #EC_RIGHTMARGIN, $FFFF * 5) ; 5 oder 6 je nach x86/x64
InputGadget_Border(id, bordernormal)
InputGadget_Vertical(id, GetGadgetFont(pbnr))
ProcedureReturn nr
EndProcedure
EndModule
UseModule InputGadget
CompilerIf #PB_Compiler_IsMainFile
Global fontStd = LoadFont(#PB_Any, "Calibri", 12)
Global font10 = LoadFont(#PB_Any, "Calibri", 10)
Global font8 = LoadFont(#PB_Any, "Calibri", 8)
OpenWindow(0, 0, 0, 500, 330, "...Gadget", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
SetGadgetFont(#PB_Default, FontID(fontStd))
InputGadget(12, 10, 20, 120, 28, "Haus" )
InputGadget(14, 10, 50, 100, 28, "Banana" )
ButtonGadget(16, 10, 80, 80, 22, "tut nix")
InputGadget(18, 10, 110, 130, 16, "bubu" )
StringGadget(20, 10, 140, 100, 24, "stringgadget")
ButtonGadget(22, 10, 170, 180, 24, "free Gadget 14")
InputGadget(24, 10, 200, 130, 30, "Read only", #PB_String_ReadOnly)
pbnr = InputGadget(#PB_Any, 10, 240, 130, 30, "mit pbany")
For j = 1 To 8
InputGadget(j, 210, j*30, 130, 24, Str(j))
SetGadgetColor(j, #PB_Gadget_FrontColor, #Blue)
Next
SetGadgetColor(12, #PB_Gadget_FrontColor, #Red)
SetGadgetColor(14, #PB_Gadget_BackColor, #Yellow)
SetGadgetFont(14, FontID(font10))
SetGadgetFont(18, FontID(font8))
SetGadgetColor(pbnr, #PB_Gadget_FrontColor, #Red)
Repeat
Event = WaitWindowEvent()
Select Event
Case #PB_Event_RightClick
Case #PB_Event_Menu
Case #PB_Event_Gadget
Select EventGadget()
Case 12 :
Select EventType()
Case #PB_EventType_Focus: Debug "#PB_EventType_Focus"
Case #PB_EventType_Change: Debug "#PB_EventType_Change"
Case #PB_EventType_LostFocus: Debug "#PB_EventType_LostFocus"
Case #PB_EventType_ReturnKey: Debug "#PB_EventType_ReturnKey"
Case #PB_EventType_RightClick: Debug "#PB_EventType_RightClick"
EndSelect
Case 8
If EventType() = #PB_EventType_ReturnKey
;springt zum angegebenen Gadget, und überschreibt damit internen Jump !!!
SetGadgetText(8, "goto 1")
SetActiveGadget(1)
EndIf
Case 22: FreeGadget(14)
EndSelect
EndSelect
Until Event = #PB_Event_CloseWindow
CompilerEndIf