Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
inc\win_ext.bas
| Uploader: |  Eternal_Pain |
| Datum/Zeit: | 19.03.2014 04:37:11 |
Hinweis: Dieser Quelltext ist Bestandteil des Projekts Windows Easy Gui (WEG), zu dem es auf FreeBASIC-Portal.de eine Projektseite gibt.
#Include "Win_Ext.bi"
#IfDef DEBUG
#Define LOGSTRING(n) FileLog(n)
Private Sub FileLog(byval logtext as String)
Dim FF as Integer = Freefile
Open "Win_Ext_Log.txt" for APPEND as #FF
Print #FF, logtext
Close #FF
End Sub
#Else
#Define LOGSTRING(n)
#EndIf
'***********************************************************************************
SUB Win_Ext_Init CONSTRUCTOR
Dim as Integer DesktopWidth, DesktopHeight
ScreenInfo DesktopWidth, DesktopHeight
'#IfNDef DEBUG
Screenres DesktopWidth,DesktopHeight,32,,-1
'#EndIf
LOGSTRING("| ** " & Time & " ** | ** " & Date & " ** | ** Log Start ** |")
Globals.ClassName = "WinExtClass"
Globals.hInstance = GetModuleHandle(NULL)
Globals.WinExtBrush = CreateSolidBrush(&hBBAAAA) 'BGR
With Globals.LogFont
.lfHeight = WinExtFontSize
.lfFaceName = WinExtFontName
End With
Globals.hFont = CreateFontIndirect(@Globals.LogFont)
Dim as WNDCLASSEX wcex
wcex.cbSize = sizeof(WNDCLASSEX)
wcex.style = CS_HREDRAW OR CS_VREDRAW
wcex.lpfnWndProc = Cast(WNDPROC,@WinExtProc)
wcex.cbClsExtra = 0
wcex.cbWndExtra = 0
wcex.hInstance = Globals.hInstance
wcex.hIcon = LoadIcon(NULL, IDI_WINLOGO)
wcex.hCursor = LoadCursor(NULL, IDC_ARROW)
wcex.hbrBackground = Globals.WinExtBrush
wcex.lpszMenuName = NULL
wcex.lpszClassName = strptr(Globals.ClassName)
wcex.hIconSm = LoadIcon(wcex.hInstance, IDI_APPLICATION)
If (RegisterClassEx(@wcex)=0) Then
LOGSTRING(Time & " | ERROR | Failed to register WinExt.")
MessageBox(NULL,"Failed to register WinExt.", "Error", NULL) : End
End If
LOGSTRING(Time & " | INFO | WinExt successfully registered.")
Using GDIPLUS
Dim as GdiplusStartupInput gdiplusStartupInput 'The GdiplusStartupInput structure holds a block
'of arguments that are required by the GdiplusStartup
'function.
'.GdiplusVersion | Type: UINT32 | Specifies the version of GDI+. Must be 1.
gdiplusStartupInput.GdiplusVersion = 1
If (GdiplusStartup(@Globals.gdiplusToken, @gdiplusStartupInput, NULL) <> 0) Then
LOGSTRING(Time & " | ERROR | Failed to initialize GDI+.")
MessageBox(NULL,"Failed to initialize GDI+.", "Error", NULL) : End
Else
LOGSTRING(Time & " | INFO | GDI+ successfully initialized.")
End If
Globals.KeyState = NEW byte[256]
Globals.KeyLayout = GetKeyboardLayout(0)
END SUB
'***********************************************************************************
SUB Win_Ext_Close DESTRUCTOR
UnregisterClass (strptr(Globals.ClassName),Globals.hInstance)
DeleteObject(Globals.WinExtBrush)
Do
If Globals.ItemList.FirstItem Then Globals.ItemList.DelItem(Globals.ItemList.FirstItem) Else Exit Do
Loop
Using GDIPLUS
GdiplusShutdown(Globals.gdiplusToken)
LOGSTRING("| ** " & Time & " ** | ** " & Date & " ** | ** Log Break ** |")
LOGSTRING("")
Delete[] Globals.KeyState
END SUB
'***********************************************************************************
Sub Item_List.AddItem(byref ThisItem as Item)
If (ThisItem = 0) Then Exit Sub
ThisItem -> PrevItem = LastItem
ThisItem -> NextItem = 0
If LastItem Then
LastItem -> NextItem = ThisItem
Else
FirstItem = ThisItem
End If
LastItem = ThisItem
'LOGSTRING(Time & " | INFO | " & ThisItem -> ID & " " & ThisItem -> Title & " added to ItemList.")
CountItem += 1
End Sub
'***********************************************************************************
Sub Item_List.DelItem(byref ThisItem as Item)
Dim as Item Temp = ThisItem
Dim as String Loghlp = Time & " | " & ThisItem -> ID & " " & ThisItem -> Title & " deleted from memory."
If ThisItem -> NextItem Then
ThisItem -> NextItem -> PrevItem = ThisItem -> PrevItem
Else
LastItem = ThisItem -> PrevItem
End If
If ThisItem -> PrevItem Then
ThisItem -> PrevItem -> NextItem = ThisItem -> NextItem
Else
FirstItem = ThisItem -> NextItem
End If
LOGSTRING(loghlp)
Temp -> Destroy()
Delete Temp
ThisItem = 0
CountItem -= 1
If LastItem = 0 andalso FirstItem<>0 Then LastItem = FirstItem
If FirstItem = 0 andalso LastItem<>0 Then FirstItem = LastItem
End Sub
'***********************************************************************************
Sub Win_Ext_Update(byval break as integer = 0)
Dim as MSG u_Msg
'(Globals.tabstophandle = NULL) orelse
while PeekMessage(@u_Msg,NULL,0,0,PM_REMOVE) 'Then
If (IsDialogMessage(Globals.tabstophandle, @u_Msg) = NULL) Then
TranslateMessage(@u_Msg)
DispatchMessage(@u_Msg)
End If
wend'End If
If break Then sleep break
End Sub
'***********************************************************************************
Function Convert_RGB_To_BGR(byval RGBValue as Integer) as Integer
Dim as Integer red,blue,green
red = lobyte(hiword(RGBValue))
blue = lobyte(loword(RGBValue))
green = RGBValue and &h00FF00
return ((blue shl 16) + green + red)
End Function
'***********************************************************************************
Function WinExtProc(byval h_Wnd as HWND, byval u_Msg as UINT, byval wParam as WPARAM, byval lParam as LPARAM) as LRESULT
Dim ItemData as Item = Cast(any ptr,GetWindowLongPtr(h_Wnd, GWLP_USERDATA))
Dim as String event
Dim as Integer eventparam
'If ItemData andalso ItemData -> ID<>WindowID Then ?ItemData -> ID
Select Case u_Msg
Case WM_GETDLGCODE 'important for IsDialogMessage
'If lParam andalso Cast(MSG ptr, @lParam) -> message = WM_KEYDOWN Then return DLGC_WANTMESSAGE
'and Cast(MSG,lParam) -> wParam
'If lParam Then return DLGC_WANTMESSAGE
return 0
Case WM_CTLCOLORSTATIC
'wParam Handle to the device context for the static control window.
'lParam Handle to the static control.
Dim as Item SubItem = Cast(any ptr,GetWindowLongPtr(cast(HWND,lParam), GWLP_USERDATA))
If SubItem Then
Select Case SubItem -> ID
Case GroupBoxID
SetBkColor(cast(HDC,wParam), Cast(Item_Group ptr, SubItem) -> FontBkColor)
SetTextColor(cast(HDC,wParam), Cast(Item_Group ptr, SubItem) -> FontColor)
If (Cast(Item_Group ptr, SubItem) -> FontBrush) Then return Cast(LRESULT,Cast(Item_Group ptr, SubItem) -> FontBrush)
SetBkMode(cast(HDC,wParam), TRANSPARENT)
return Cast(LRESULT,Globals.WinExtBrush)
Case StaticTextID
SetBkColor(Cast(HDC,wParam), Cast(Item_StaticText ptr, SubItem) -> BColor)
SetTextColor(Cast(HDC,wParam), Cast(Item_StaticText ptr, SubItem) -> FColor)
If (Cast(Item_StaticText ptr, SubItem) -> BckBrush) Then return Cast(LRESULT, Cast(Item_StaticText ptr, SubItem) -> BckBrush)
SetBkMode(Cast(HDC,wParam), TRANSPARENT)
return Cast(LRESULT,Globals.WinExtBrush)
Case Else
SetBkMode(cast(HDC,wParam), TRANSPARENT)
return Cast(LRESULT,Globals.WinExtBrush)
End Select
End If
Exit Select
Case WM_COMMAND
Dim as Item SubItem
SubItem = Cast(any ptr,GetWindowLongPtr(Cast(HWND,lParam), GWLP_USERDATA))
If SubItem = 0 Then SubItem = Cast(any ptr,GetWindowLongPtr(GetFocus(), GWLP_USERDATA))
If SubItem = 0 Then Exit Select
Dim as Integer SpinVal
Dim as String SpinTxt
Dim as RECT cRECT
Dim as HDC hDC
Dim as Integer cw,ch
If (hiword(wParam) = EN_SETFOCUS) or (hiword(wParam) = EN_KILLFOCUS) Then
If SubItem <> 0 andalso ItemData <> 0 andalso (SubItem <> ItemData) andalso (ItemData -> ID = WindowID) andalso (SubItem -> ID <> WindowID) Then
GetClientRect(SubItem -> whwnd, @cRECT)
cw = cRECT.right - cRECT.left
ch = cRECT.bottom - cRECT.top
If SubItem -> ID = SpinBoxID Then
GetClientRect(Cast(Item_Spin ptr, SubItem) -> shwnd, @cRECT)
cw += cRECT.right - cRECT.left
End If
MapWindowPoints(SubItem -> whwnd, ItemData -> whwnd, Cast(LPPOINT,@cRECT),2)
hDC = GetDC(ItemData -> whwnd)
cRECT.right = cRECT.left + cw + 3
cRECT.bottom = cRECT.top + ch + 3
cRECT.left -= 4
cRECT.top -= 4
DrawFocusRect(hDC, @cRECT)
End If
End If
If SubItem andalso SubItem -> ID = SpinBoxID Then
SpinTxt = space(255)
SpinTxt = left(SpinTxt,GetWindowText(SubItem -> whwnd, SpinTxt, len(SpinTxt)))
SpinVal = Val(SpinTxt)
If (SpinVal < (Cast(Item_Spin ptr, SubItem) -> minVal)) Then
SpinVal = Cast(Item_Spin ptr, SubItem) -> minVal
SetWindowText(SubItem -> whwnd,str(Cast(Item_Spin ptr, SubItem) -> minVal))
SendMessage(Cast(Item_Spin ptr, SubItem) -> shwnd, UDM_SETPOS32 , NULL , SpinVal)
ElseIf (SpinVal > (Cast(Item_Spin ptr, SubItem) -> maxVal)) Then
SpinVal = Cast(Item_Spin ptr, SubItem) -> maxVal
SetWindowText(SubItem -> whwnd,str(Cast(Item_Spin ptr, SubItem) -> maxVal))
SendMessage(Cast(Item_Spin ptr, SubItem) -> shwnd, UDM_SETPOS32 , NULL , SpinVal)
Else
If (hiword(wParam) = EN_KILLFOCUS) and (SpinTxt<>str(SpinVal)) Then
SetWindowText(SubItem -> whwnd,str(SpinVal))
SendMessage(Cast(Item_Spin ptr, SubItem) -> shwnd, UDM_SETPOS32 , NULL , SpinVal)
End If
End If
End If
If wParam = IDOK andalso SubItem Then
If SubItem -> ID = SpinBoxID orelse SubItem -> ID = EditBoxID Then PostMessage(SubItem -> whwnd,WM_KEYDOWN,VK_TAB, NULL)
End If
If wParam = IDCANCEL Then SetFocus(h_Wnd)
Exit Select
Case WM_KILLFOCUS
Case WM_SETFOCUS
Case WM_MEASUREITEM
'wParam Contains the value of the CtlID member of the MEASUREITEMSTRUCT structure pointed to by the lParam parameter.
' This value identifies the control that sent the WM_MEASUREITEM message. If the value is zero, the message was sent by a menu.
' If the value is nonzero, the message was sent by a combo box or by a list box. If the value is nonzero,
' and the value of the itemID member of the MEASUREITEMSTRUCT pointed to by lParam is (UINT) –1,
' the message was sent by a combo edit field.
'
'lParam Pointer to a MEASUREITEMSTRUCT structure that contains the dimensions of the owner-drawn control or menu item.
'
'typedef struct MEASUREITEMSTRUCT {
'UINT CtlType;
'UINT CtlID;
'UINT itemID;
'UINT itemWidth;
'UINT itemHeight;
'ULONG_PTR itemData;
'} MEASUREITEMSTRUCT;
'?h_Wnd,ItemData -> whwnd, ItemData -> ID
Dim as LPMEASUREITEMSTRUCT lpmis = cast(LPMEASUREITEMSTRUCT, lParam)
If (lpmis -> CtlType = ODT_COMBOBOX) andalso (lpmis -> ItemData) Then
'ImageComboBox
Dim as String SubItemS = *cast(wstring ptr,lpmis->itemdata)
Dim as UInteger SubAdr = Val(SubItemS)
Dim as Item SubItem
If len(SubItemS) Then SubItem = Cast(any ptr, SubAdr)
If SubItem andalso SubItem -> ID = ImageComboID Then
lpmis->ItemHeight = Cast(Item_ImageCombo ptr, SubItem) -> iHeight
exit select
End If
'FontSelectCombo
'If SubItem andalso SubItem -> ID = FontSelectComboID Then lpmis->ItemHeight = Cast(Item_FontSelectCombo ptr, SubItem) -> iHeight
End If
Case WM_DRAWITEM
'wParam Specifies the identifier of the control that sent the WM_DRAWITEM message.
' If the message was sent by a menu, this parameter is zero.
'
'lParam Pointer to a DRAWITEMSTRUCT structure containing information about the item to be drawn and the type of drawing required.
'
'typedef struct tagDRAWITEMSTRUCT {
'UINT CtlType;
'UINT CtlID;
'UINT itemID;
'UINT itemAction;
'UINT itemState;
'HWND hwndItem;
'HDC hDC;
'RECT rcItem;
'ULONG_PTR itemData;
'} DRAWITEMSTRUCT;
Dim as LPDRAWITEMSTRUCT lpdis = Cast(any ptr, lParam)
Dim as Item SubItem = Cast(any ptr, GetWindowLongPtr(lpdis -> hwndItem, GWLP_USERDATA))
Dim as HDC hdc = CreateCompatibleDC(lpdis -> hDC)
Dim as Integer iw, ih
Dim as HBRUSH hl
If SubItem Then
Select Case SubItem -> ID
Case ImageComboID
If Cast(Integer, lpdis -> ItemID) = -1 Then Exit Select
FillRect(lpdis -> hDC, @lpdis->rcItem, NULL)
iw = lpdis -> rcItem.right - lpdis -> rcItem.left
ih = lpdis -> rcItem.bottom - lpdis -> rcItem.top
SelectObject(hdc, Cast(Item_ImageCombo ptr, SubItem) -> IList[lpdis -> ItemID]) 'select image
BitBlt(lpdis -> hDC, lpdis -> rcItem.left + 1, lpdis -> rcItem.top + 1, iw-2, ih-1, hdc, 0, 0, SRCCOPY)
DeleteDC(hdc)
If (lpdis -> itemState AND ODS_FOCUS) Then
InvertRect(lpdis -> hDC, @lpdis->rcItem)
DrawFocusRect(lpdis -> hDC, @lpdis->rcItem)
End If
return true
Case FontSelectComboID
'If Cast(Integer, lpdis -> ItemID) = -1 Then Exit Select
Dim as Integer clrForeground, clrBackground, wy = lpdis->rcItem.top
Dim as String FontNameString = space(999)
Dim as LOGFONT FntStyle
Dim as HFONT newFont
Dim as SIZE fSize
FontNameString = Left(FontNameString,SendMessage(lpdis->hwndItem, CB_GETLBTEXT, lpdis->itemID, cast(LPARAM, strptr(FontNameString))))
FntStyle.lfFaceName = FontNameString
newFont = CreateFontIndirect(@FntStyle)
Dim as HDC fDC = CreateCompatibleDC(lpdis->hDC)
SelectObject(fDC, newFont)
GetTextExtentPoint32(fDC,FontNameString,len(FontNameString),@fSize)
DeleteDC(fDC)
Dim as Integer xp = int(( (lpdis->rcItem.right - lpdis->rcItem.left) / 2 ) - (fSize.CX/2)) + lpdis->rcItem.left
Dim as Integer yp = int(( (lpdis->rcItem.bottom - lpdis->rcItem.top ) / 2 ) - (fSize.CY/2)) + lpdis->rcItem.top
clrForeground = SetTextColor(lpdis->hDC, GetSysColor(IIF(lpdis->itemState and ODS_SELECTED,COLOR_HIGHLIGHTTEXT, COLOR_WINDOWTEXT)))
clrBackground = SetBkColor(lpdis->hDC, GetSysColor(IIF(lpdis->itemState and ODS_SELECTED, COLOR_HIGHLIGHT, COLOR_WINDOW)))
SetBkMode(lpdis->hDC, TRANSPARENT)
SelectObject(lpdis->hDC, newFont)
if (lpdis->itemState and ODS_COMBOBOXEDIT) Then wy = yp
ExtTextOut(lpdis->hDC, xp, wy, ETO_CLIPPED OR ETO_OPAQUE, @lpdis->rcItem, strptr(FontNameString), len(FontNameString), NULL)
DeleteObject(newFont)
SetTextColor(lpdis->hDC, clrForeground)
SetBkColor(lpdis->hDC, clrBackground)
return true
End Select
End If
Case WM_PAINT
Dim as PAINTSTRUCT ps
Dim as HDC hDC = BeginPaint(h_Wnd, @ps)
EndPaint(h_Wnd, @ps)
return FALSE
Case WM_ACTIVATE
If wParam Then
Globals.tabstophandle = h_Wnd'ItemData -> whwnd
Else
Globals.tabstophandle = NULL
End If
return FALSE
Case WM_KEYUP
Globals.KeyState[wParam] = 0
exit select
Case WM_KEYDOWN
Globals.KeyState[wParam] = 1
If GetKeyboardState(Globals.KeyState) Then
Dim as ubyte scancode = lobyte(hiword(lParam))
Dim as UINT vk = MapVirtualKeyEx(scancode,1,Globals.KeyLayout)
Dim as ushort result
If ToAsciiEx(vk,scancode,Globals.KeyState,@result,0,Globals.KeyLayout) Then
If ItemData andalso ItemData -> ID = WindowID Then Cast(Item_Window ptr,ItemData) -> WindowKey = chr(lobyte(result))
End If
End If
exit select
Case WM_LBUTTONDOWN
SetFocus(h_Wnd)
Case WM_CLOSE
If ItemData andalso ItemData -> ID = WindowID Then Cast(Item_Window ptr,ItemData) -> WindowKey = chr(&hFF,&h6B)
Return FALSE
End Select
return DefWindowProc(h_Wnd, u_Msg, wParam, lParam)
End Function