 |
Das deutsche QBasic- und FreeBASIC-Forum
Für euch erreichbar unter qb-forum.de, fb-forum.de und freebasic-forum.de!
|
| Vorheriges Thema anzeigen :: Nächstes Thema anzeigen |
| Autor |
Nachricht |
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 148
Wohnort: Opel Stadt
|
 Verfasst am: 24.02.2020, 14:13 Titel: Color Constants v0.83 build 2026-07-07 [nur Windows] |
 |
|
Hier ein kleines Tool zum Anzeigen von Farbwerten zwecks z.B. GUI Farbgestaltung.
Nach dem Starten wir die Datei ColorConstants.txt erstellt, die dann in der GUI dargestellt wird.
Ein Doppelklick auf den Eintrag in der Spalte "Color Name" kopiert den Farbwert in den Zwischenspeicher.
Das Input Feld kann benutzt werden, um nach bestimmten Farben zu filtern.
Download Code + Exe: Color Constants v0.83 build 2026-07-07
| Code: |
'Coded by UEZ build 2026-07-07
#ifdef __FB_64BIT__
#cmdline "-s gui -x ""Color Constants64.exe"" -gen gcc -Wc -Os 'Color Constants.rc'"
#else
#cmdline "-s gui -x ""Color Constants.exe"" -gen gcc -Wc -Os 'Color Constants.rc'"
#endif
#Include "fbgfx.bi" 'needed for LZW
#Include "VBcompat.bi"
#Include "windows.bi"
#Include "win\commctrl.bi"
#Include "win\commdlg.bi"
#include "win\shellapi.bi"
#Include "_WinAPI_DpiAwareness.bi"
Declare Function WndProc(hWnd As HWND, wMsg As Uint, wParam As WPARAM, lParam As LPARAM) As LRESULT
Declare Function LV_InsertColumn(Byval hWndControl As HWND, Byval iPosition As Integer, Byref sString As String, Byval nAlignment As Integer = LVCFMT_LEFT, Byval nWidth As Integer = 100) As Integer
Declare Function LV_InsertItem(Byval hWndControl As HWND, Byval iRow As Integer, Byval iColumn As Integer, Byref sString As String, Byval lParam As Integer = 0, Byval iImage As Integer = 0) As Integer
Declare Function _WinAPI_CreateToolTip(hDlg As HWND, sToolTipText As String, bBalloon As Ubyte = 1, iWidth As Ushort = 500, toolID As Integer = 0) As HWND
Declare Function Base64Decode(sString As String, Byref iBase64Len as Uinteger) As Ubyte Ptr
Declare Function LZW_Decode Alias "fb_hDecode" (Byval in_buffer As Any Ptr, Byval in_size As Integer, Byval out_buffer As Any Ptr, Byref out_size As Integer) As Integer
Declare Function ChooseRGB(Byref bOk As Boolean) As Ulong
Declare Sub RefreshList(Byref sFilter As String)
Declare Sub SortTable(Byval iCol As Long)
Declare Function FindNearestColor(Byval iRGB As Ulong) As Long
Declare Sub SelectNearest(Byval iRGB As Ulong, Byval bMsg As Boolean = TRUE)
Declare Sub StartPicking()
Declare Sub StopPicking()
Declare Sub UpdateZoom()
Declare Sub ApplyLayout(Byval iNewDpi As Ulong)
#Define DPIScale(n) MulDiv((n), iDpi, 96)
Function EnableVisualStylesRuntime() As BOOL ' thanks to Josep Roca
Dim As ACTCTXW actCtx
actCtx.cbSize = SizeOf(ACTCTXW)
actCtx.dwFlags = ACTCTX_FLAG_RESOURCE_NAME_VALID Or ACTCTX_FLAG_SET_PROCESS_DEFAULT Or ACTCTX_FLAG_ASSEMBLY_DIRECTORY_VALID
Dim As WString * MAX_PATH systemDir
Dim As UINT cch = GetSystemDirectoryW(@systemDir, MAX_PATH)
If cch >= MAX_PATH Then Return False
systemDir[cch] = Asc("\")
actCtx.lpAssemblyDirectory = @systemDir
Dim As WString * MAX_PATH wszSource = systemDir & "shell32.dll"
actCtx.lpSource = Cast(WString Ptr, @wszSource)
actCtx.lpResourceName = Cast(WString Ptr, 124)
Dim As HANDLE hActCtx = CreateActCtxW(@actCtx)
If hActCtx = INVALID_HANDLE_VALUE Then Return False
Dim As ULONG_PTR activationCookie
ActivateActCtx(hActCtx, @activationCookie)
DeactivateActCtx(0, activationCookie)
ReleaseActCtx(hActCtx)
Return True
End Function
EnableVisualStylesRuntime() 'activate Common Controls v6
'Per-Monitor V2 DPI awareness with fallbacks (physical pixel coords for the screen picker)
If _WinAPI_SetProcessDpiAwarenessContext(DPI_AWARENESS_CONTEXT_PER_MONITOR_AWARE_V2) = FALSE Then
If _WinAPI_SetProcessDpiAwareness(PROCESS_PER_MONITOR_DPI_AWARE) <> S_OK Then _WinAPI_SetProcessDPIAware()
End If
Dim icc As INITCOMMONCONTROLSEX
icc.dwSize = SizeOf(INITCOMMONCONTROLSEX)
icc.dwICC = ICC_STANDARD_CLASSES Or ICC_WIN95_CLASSES
INITCOMMONCONTROLSEX(@icc)
#Define LV_WM_SETREDRAW 11
Const sTitle = "Color Constants v0.83 by UEZ"
Dim As String sFile = Curdir & "\ColorConstants.txt"
If Fileexists(sFile) = 0 Then
Dim As Uinteger iLines, iCompression, iFileSize, iCompressedSize, l
Dim as String aB64(1), sB64, sBaseType
Restore __Label0:
Read iLines
Read iCompression
Read iFileSize
Read iCompressedSize
Read sBaseType
For i as uByte = 0 to iLines
Read aB64(0)
sB64 &= aB64(0)
Next
Dim As UByte Ptr aBinary = Base64Decode(sB64, l)
If l <> iCompressedSize Then
? "Error in decoding base64!"
Beep
Else
Dim As Integer hFile
hFile = Freefile()
Open sFile For Binary Access Write As #hFile
If iCompression Then
Dim As Ubyte Ptr aBinaryC = Allocate(iFileSize)
LZW_Decode(aBinary, iCompressedSize, aBinaryC, iFileSize)
Put #hFile, 0, aBinaryC[0], iFileSize
Deallocate(aBinaryC)
Else
Put #hFile, 0, aBinary[0], iFileSize
Endif
Close #hFile
aBinary = 0
End If
End If
Dim Shared As HFONT hFont, hFontBtn
Dim Shared As HWND hGUI, hButton_exit, hListView, hCheckbox, hCheckbox2, hButton_pick, hInput
Dim Shared As Boolean bChkBox = FALSE, bChkBox2 = FALSE
Dim Shared As HMENU hSysMenu
Dim Shared As HICON hIcon
Dim Shared As Long iSortCol = -1
Dim Shared As Boolean bPicking = FALSE
Dim Shared As HWND hZoom = 0, hButton_screen
Dim Shared As HDC hdcZoomMem = 0
Dim Shared As HBITMAP hbmZoom = 0, hbmZoomOld = 0
Dim Shared As Ulong iPickedBGR = 0
Dim Shared As Ulong iDpi = 96
Const iZoomW = 150, iZoomH = 172, iZoomPix = 15 'zoom area: 15x15 px -> 150x150 (factor 10) + 22 px hex bar
Dim Shared As Boolean bSortAsc = TRUE
Const id_About = 5000
Const maxGUIHeight = 0.96
Dim As WNDCLASS WinCls
#Ifdef unicode
Dim szClassName As Wstring * 64
Dim szCaption As Wstring * 64
#Else
Dim szClassName As Zstring * 64
Dim szCaption As Zstring * 64
#Endif
szClassName = "FB_GUI"
With WinCls
.style = CS_HREDRAW Or CS_VREDRAW
.lpfnWndProc = Cast(WNDPROC, @WndProc)
.hInstance = GetModuleHandle(NULL)
.hIcon = LoadIcon(NULL, IDI_APPLICATION)
.hCursor = LoadCursor(NULL, IDC_ARROW)
.hbrBackground = GetSyscolorbrush(COLOR_3DFACE)
.lpszMenuName = NULL
.lpszClassName = Strptr(szClassName)
End With
If RegisterClass(@WinCls) = False Then
MessageBox(NULL, "RegisterClass('WindowClass') FAIL!", "Error!", MB_OK Or MB_ICONERROR)
End
End If
Dim As WNDCLASS ZoomCls
With ZoomCls
.style = CS_HREDRAW Or CS_VREDRAW
.lpfnWndProc = @DefWindowProc
.hInstance = GetModuleHandle(NULL)
.hCursor = LoadCursor(NULL, IDC_CROSS)
.hbrBackground = Cast(HBRUSH, GetStockObject(BLACK_BRUSH))
.lpszClassName = @"FB_ZOOM"
End With
RegisterClass(@ZoomCls)
#Define CrLf Chr(13) & Chr(10)
iDpi = _WinAPI_GetDpiForSystem()
If iDpi = 0 Then iDpi = 96
Dim As Long iW = DPIScale(455), iH = DPIScale(725), lvh = 0 'controls get positioned by ApplyLayout()
hGUI = CreateWindowEx(0, szClassName, sTitle, WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_MINIMIZEBOX, _
CW_USEDEFAULT, CW_USEDEFAULT, iW, iH, NULL, NULL, NULL, NULL)
hListView = CreateWindowEx(0, "SysListView32", "", WS_BORDER Or WS_CHILD Or WS_VISIBLE Or WS_CLIPSIBLINGS Or _
LVS_REPORT Or LVS_SINGLESEL Or LVS_SHOWSELALWAYS, _
0, 0, 10, 10, hGUI, NULL, NULL, NULL)
SendMessage(hListView, LVM_SETEXTENDEDLISTVIEWSTYLE, 0, WS_EX_CLIENTEDGE Or LVS_EX_GRIDLINES Or LVS_EX_FULLROWSELECT)
hButton_pick = CreateWindowEx(0, "Button", "Pick Color", WS_VISIBLE Or WS_CHILD, 0, 0, 10, 10, hGUI, NULL, NULL, NULL)
_WinAPI_CreateToolTip(hButton_pick, "Choose a color from a dialog - the nearest named color will be selected in the list")
hButton_screen = CreateWindowEx(0, "Button", "Pick Screen", WS_VISIBLE Or WS_CHILD, 0, 0, 10, 10, hGUI, NULL, NULL, NULL)
_WinAPI_CreateToolTip(hButton_screen, "Pick a color anywhere from the screen using a zoom lens." & CrLf & "Left click = pick, right click / ESC = cancel")
hButton_exit = CreateWindowEx(0, "Button", "Exit", WS_VISIBLE Or WS_CHILD, 0, 0, 10, 10, hGUI, NULL, NULL, NULL)
hCheckbox = CreateWindowEx(0, "Button", "Add &&h prefix for hex color value", BS_AUTOCHECKBOX Or WS_VISIBLE Or WS_CHILD, 0, 0, 10, 10, hGUI, Cast(HMENU, 2), NULL, NULL)
CheckDlgButton(hGUI, 2, BST_CHECKED)
_WinAPI_CreateToolTip(hCheckbox, "If checked than the prefix &h will be added to the color value" & CrLf & "which will be copied to the clipboard")
hCheckbox2 = CreateWindowEx(0, "Button", "Use 32-bit hex length (ARGB)", BS_AUTOCHECKBOX Or WS_VISIBLE Or WS_CHILD, 0, 0, 10, 10, hGUI, Cast(HMENU, 3), NULL, NULL)
_WinAPI_CreateToolTip(hCheckbox2, "Adds Alpha channel to color value")
hInput = CreateWindowEx(0, "Edit", NULL, WS_VISIBLE Or WS_CHILD Or WS_BORDER, 0, 0, 10, 10, hGUI, NULL, NULL, NULL)
_WinAPI_CreateToolTip(hInput, "Enter a text to filter by color name or hex value (min. 2 chars). ESC clears the filter.")
SendMessage(hInput, EM_SETLIMITTEXT, 254, 0)
LV_InsertColumn(hListView, 0, "Color Name", LVCFMT_LEFT, 150)
LV_InsertColumn(hListView, 1, "RGB Hex Value", LVCFMT_LEFT, 100)
LV_InsertColumn(hListView, 2, "RGB Color Preview", LVCFMT_LEFT, 150)
'use the actual DPI of the monitor the window was created on
Dim As Ulong iWndDpi = _WinAPI_GetDpiForWindow(hGUI)
If iWndDpi Then iDpi = iWndDpi
Dim As Long iWinW = DPIScale(455), iWinH = DPIScale(725)
Dim As HMONITOR hMon = MonitorFromWindow(hGUI, MONITOR_DEFAULTTONEAREST)
Dim As MONITORINFO tMI : tMI.cbSize = Sizeof(tMI)
Dim As Long px = CW_USEDEFAULT, py = CW_USEDEFAULT
If GetMonitorInfo(hMon, @tMI) Then
Dim As Long iMaxH = (tMI.rcWork.bottom - tMI.rcWork.top) * maxGUIHeight
If iWinH > iMaxH Then iWinH = iMaxH
px = tMI.rcWork.left + ((tMI.rcWork.right - tMI.rcWork.left) - iWinW) \ 2
py = tMI.rcWork.top + ((tMI.rcWork.bottom - tMI.rcWork.top) - iWinH) \ 2
End If
SetWindowPos(hGUI, NULL, px, py, iWinW, iWinH, SWP_NOZORDER Or SWP_NOACTIVATE)
ApplyLayout(iDpi)
ShowWindow(hGUI, SW_SHOWNORMAL)
hSysMenu = GetSystemMenu(hGUI, False)
AppendMenu(hSysMenu, MF_SEPARATOR, 0, 0)
AppendMenu(hSysMenu, MF_STRING, id_About, "&About")
Dim SystemDir As Zstring * MAX_PATH
GetSystemDirectory(@SystemDir, MAX_PATH)
ExtractIconEx(SystemDir & "\Shell32.dll", 161, NULL, @hIcon, 1)
SendMessageW(hGUI, WM_SETICON, 1, Cast(lParam, hIcon))
Dim As String sLine
Dim As Integer iFilenum, iRes, iLine = 0
Dim Shared As Long iTokens
Dim Shared As String aColorTable()
Redim aColorTable(10000, 1)
iFilenum = Freefile
iRes = Open (sFile, For Input, As #iFilenum)
While (Not Eof(iFilenum))
Line Input #iFilenum, sLine
If sLine <> "" Then
If iLine > Ubound(aColorTable) Then Redim Preserve aColorTable(2 * iLine, 1)
aColorTable(iLine, 0) = Left(sLine, Instr(sLine, ";") - 1)
aColorTable(iLine, 1) = Right(sLine, Len(sLine) - Instr(sLine, ";"))
iLine += 1
End If
Wend
Close #iFilenum
iTokens = iLine
Dim Shared As String sCurFilter
sCurFilter = ""
RefreshList(sCurFilter)
SendMessage(hListView, LV_WM_SETREDRAW, True, 0)
ShowWindow(hGUI, SW_SHOWNORMAL)
UpdateWindow(hGUI)
Dim As MSG uMsg
If IsDlgButtonChecked(hGUI, GetDlgCtrlID(hCheckbox)) Then bChkBox = True
If IsDlgButtonChecked(hGUI, GetDlgCtrlID(hCheckbox2)) Then bChkBox2 = True
While GetMessage(@uMsg, 0, 0, 0)
'Feature: ESC in the filter edit clears the filter instead of quitting
If uMsg.hwnd = hInput And uMsg.message = WM_KEYDOWN And uMsg.wParam = VK_ESCAPE Then
If GetWindowTextLength(hInput) > 0 Then
SetWindowText(hInput, "")
Continue While
Else
DestroyWindow(hGUI)
Continue While
End If
End If
TranslateMessage(@uMsg)
DispatchMessage(@uMsg)
Select Case uMsg.hwnd
Case hListView
Select Case uMsg.message
Case WM_KEYDOWN
Select Case uMsg.wParam
Case VK_ESCAPE
DestroyWindow(hGUI)
End Select
End Select
End Select
Wend
DeleteObject(hFont)
If hFontBtn Then DeleteObject(hFontBtn)
If hIcon Then DestroyIcon(hIcon)
End
'DPI: (re)position and (re)scale all controls + font for the given DPI
Sub ApplyLayout(Byval iNewDpi As Ulong)
iDpi = iNewDpi
Dim As RECT rcC : GetClientRect(hGUI, @rcC)
Dim As Long cw = rcC.right, ch = rcC.bottom, m = DPIScale(10)
If hFont Then DeleteObject(hFont)
If hFontBtn Then DeleteObject(hFontBtn)
hFont = CreateFont(DPIScale(14), 0, 0, 0, FW_MEDIUM, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, CLEARTYPE_QUALITY, FF_DONTCARE, "Arial")
hFontBtn = CreateFont(DPIScale(15), 0, 0, 0, FW_MEDIUM, 0, 0, 0, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, CLEARTYPE_QUALITY, FF_DONTCARE, "Arial")
SendMessage(hListView, WM_SETFONT, Cast(WPARAM, hFont), MAKELPARAM(True, 0))
SendMessage(hInput, WM_SETFONT, Cast(WPARAM, hFont), MAKELPARAM(True, 0))
SendMessage(hButton_pick, WM_SETFONT, Cast(WPARAM, hFontBtn), MAKELPARAM(True, 0))
SendMessage(hButton_screen, WM_SETFONT, Cast(WPARAM, hFontBtn), MAKELPARAM(True, 0))
SendMessage(hButton_exit, WM_SETFONT, Cast(WPARAM, hFontBtn), MAKELPARAM(True, 0))
SendMessage(hCheckbox, WM_SETFONT, Cast(WPARAM, hFont), MAKELPARAM(True, 0))
SendMessage(hCheckbox2, WM_SETFONT, Cast(WPARAM, hFont), MAKELPARAM(True, 0))
MoveWindow(hListView, m, m, cw - 2 * m, ch - DPIScale(111), TRUE)
MoveWindow(hInput, m, ch - DPIScale(96), cw - 2 * m, DPIScale(20), TRUE)
MoveWindow(hCheckbox, m, ch - DPIScale(71), DPIScale(240), DPIScale(24), TRUE)
MoveWindow(hCheckbox2, m, ch - DPIScale(43), DPIScale(240), DPIScale(24), TRUE)
MoveWindow(hButton_pick, cw - DPIScale(190), ch - DPIScale(71), DPIScale(88), DPIScale(24), TRUE)
MoveWindow(hButton_screen, cw - DPIScale(190), ch - DPIScale(43), DPIScale(88), DPIScale(24), TRUE)
MoveWindow(hButton_exit, cw - DPIScale(95), ch - DPIScale(71), DPIScale(70), DPIScale(24), TRUE)
SendMessage(hListView, LVM_SETCOLUMNWIDTH, 0, DPIScale(150))
SendMessage(hListView, LVM_SETCOLUMNWIDTH, 1, DPIScale(100))
SendMessage(hListView, LVM_SETCOLUMNWIDTH, 2, DPIScale(150))
End Sub
'Feature: rebuild list view according to current filter (name OR hex) + update title
Sub RefreshList(Byref sFilter As String)
Dim As Long i, j = 0
Dim As String sF = Lcase(sFilter)
SendMessage(hListView, LV_WM_SETREDRAW, False, 0)
SendMessage(hListView, LVM_DELETEALLITEMS, 0, 0)
For i = 0 To iTokens - 1
If Len(sF) < 2 Orelse Instr(Lcase(aColorTable(i, 0)), sF) Orelse Instr(Lcase(aColorTable(i, 1)), sF) Then
LV_InsertItem(hListView, j, 0, aColorTable(i, 0))
LV_InsertItem(hListView, j, 1, aColorTable(i, 1))
j += 1
End If
Next
SendMessage(hListView, LV_WM_SETREDRAW, True, 0)
SetWindowText(hGUI, sTitle & " / " & j & " of " & iTokens & " colors displayed")
End Sub
'Feature: sort underlying table by column (0 = name, 1 = hex value numeric), toggle asc/desc
Sub SortTable(Byval iCol As Long)
If iCol > 1 Then Exit Sub 'preview column not sortable
If iCol = iSortCol Then bSortAsc = Not bSortAsc Else bSortAsc = TRUE
iSortCol = iCol
Dim As Long i, gap = iTokens \ 2
Dim As Boolean bSwap
Dim As String s0, s1
While gap > 0 'shell sort
For i = gap To iTokens - 1
Dim As Long k = i
While k >= gap
If iCol = 0 Then
bSwap = Iif(bSortAsc, Lcase(aColorTable(k - gap, 0)) > Lcase(aColorTable(k, 0)), Lcase(aColorTable(k - gap, 0)) < Lcase(aColorTable(k, 0)))
Else
Dim As Ulong v1 = Culng(Valint("&h" & aColorTable(k - gap, 1))), v2 = Culng(Valint("&h" & aColorTable(k, 1)))
bSwap = Iif(bSortAsc, v1 > v2, v1 < v2)
End If
If bSwap Then
Swap aColorTable(k - gap, 0), aColorTable(k, 0)
Swap aColorTable(k - gap, 1), aColorTable(k, 1)
k -= gap
Else
Exit While
End If
Wend
Next
gap \= 2
Wend
RefreshList(sCurFilter)
End Sub
'Feature: find index (in list view order = filtered view!) of the nearest named color
Function FindNearestColor(Byval iRGB As Ulong) As Long
Dim As Long i, iBest = -1
Dim As Ulong iBestDist = &hFFFFFFFF, c, d
Dim As Long r = (iRGB Shr 16) And &hFF, g = (iRGB Shr 8) And &hFF, b = iRGB And &hFF, dr, dg, db
For i = 0 To iTokens - 1
c = Culng(Valint("&h" & aColorTable(i, 1)))
dr = r - ((c Shr 16) And &hFF)
dg = g - ((c Shr 8) And &hFF)
db = b - (c And &hFF)
d = dr * dr + dg * dg + db * db
If d < iBestDist Then
iBestDist = d
iBest = i
End If
Next
Return iBest
End Function
'Feature: select the nearest named color in the list view (clears the filter first)
Sub SelectNearest(Byval iRGB As Ulong, Byval bMsg As Boolean = TRUE)
SetWindowText(hInput, "") 'clear filter so the item is present
Dim As Long iIdx = FindNearestColor(iRGB)
If iIdx = -1 Then Exit Sub
Dim As LVFINDINFO tFind
tFind.flags = LVFI_STRING
tFind.psz = Strptr(aColorTable(iIdx, 0))
Dim As Long iRow = SendMessage(hListView, LVM_FINDITEM, Cast(WPARAM, -1), Cast(LPARAM, @tFind))
If iRow = -1 Then Exit Sub
Dim As LVITEM tSel
tSel.state = LVIS_SELECTED Or LVIS_FOCUSED
tSel.stateMask = LVIS_SELECTED Or LVIS_FOCUSED
SendMessage(hListView, LVM_SETITEMSTATE, iRow, Cast(LPARAM, @tSel))
SendMessage(hListView, LVM_ENSUREVISIBLE, iRow, FALSE)
SetFocus(hListView)
If bMsg Then MessageBox(hGUI, "Picked color: " & Hex(iRGB, 6) & CrLf & "Nearest named color: " & aColorTable(iIdx, 0) & " (" & aColorTable(iIdx, 1) & ")", "Pick Color", MB_ICONINFORMATION Or MB_OK)
End Sub
'Feature: screen eyedropper with zoom lens
Sub StartPicking()
If bPicking Then Exit Sub
bPicking = TRUE
'backbuffer for the zoom lens (created once per pick session)
Dim As HDC hdcScr = GetDC(0)
hdcZoomMem = CreateCompatibleDC(hdcScr)
hbmZoom = CreateCompatibleBitmap(hdcScr, iZoomW, iZoomH)
hbmZoomOld = SelectObject(hdcZoomMem, hbmZoom)
ReleaseDC(0, hdcScr)
hZoom = CreateWindowEx(WS_EX_TOPMOST Or WS_EX_TOOLWINDOW Or WS_EX_NOACTIVATE, "FB_ZOOM", "", WS_POPUP, 0, 0, iZoomW, iZoomH, hGUI, NULL, NULL, NULL)
SetCapture(hGUI) 'intercepts the button click; movement is driven by the timer below
SetCursor(LoadCursor(NULL, IDC_CROSS))
GetAsyncKeyState(VK_LBUTTON) 'reset the "pressed since last call" bit
SetTimer(hGUI, 1, 15, NULL) 'mouse capture does NOT deliver WM_MOUSEMOVE outside the window when no button is down!
UpdateZoom()
ShowWindow(hZoom, SW_SHOWNOACTIVATE)
End Sub
Sub StopPicking()
If bPicking = FALSE Then Exit Sub
bPicking = FALSE
KillTimer(hGUI, 1)
ReleaseCapture()
If hZoom Then DestroyWindow(hZoom) : hZoom = 0
If hdcZoomMem Then
SelectObject(hdcZoomMem, hbmZoomOld)
DeleteObject(hbmZoom) : hbmZoom = 0
DeleteDC(hdcZoomMem) : hdcZoomMem = 0
End If
SetWindowPos(hGUI, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOACTIVATE)
SetWindowPos(hGUI, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOACTIVATE)
SetForegroundWindow(hGUI)
End Sub
Sub UpdateZoom()
If hZoom = 0 Then Exit Sub
If GetAsyncKeyState(VK_ESCAPE) And &h8000 Then 'capture doesn't route keyboard -> poll ESC here
StopPicking()
Exit Sub
End If
Dim As POINT pt : GetCursorPos(@pt)
'position the lens next to the cursor, flip near the virtual screen edges
Dim As Long vx = GetSystemMetrics(SM_XVIRTUALSCREEN), vy = GetSystemMetrics(SM_YVIRTUALSCREEN)
Dim As Long vw = GetSystemMetrics(SM_CXVIRTUALSCREEN), vh = GetSystemMetrics(SM_CYVIRTUALSCREEN)
Dim As Long wx = pt.x + 24, wy = pt.y + 24
If wx + iZoomW > vx + vw Then wx = pt.x - 24 - iZoomW
If wy + iZoomH > vy + vh Then wy = pt.y - 24 - iZoomH
SetWindowPos(hZoom, HWND_TOPMOST, wx, wy, 0, 0, SWP_NOSIZE Or SWP_NOACTIVATE)
Dim As HDC hdcScr = GetDC(0)
Dim As Long iHalf = iZoomPix \ 2, iCell = iZoomW \ iZoomPix
'zoomed screen area
SetStretchBltMode(hdcZoomMem, COLORONCOLOR)
StretchBlt(hdcZoomMem, 0, 0, iZoomW, iZoomW, hdcScr, pt.x - iHalf, pt.y - iHalf, iZoomPix, iZoomPix, SRCCOPY)
'pixel grid
Dim As HPEN hPenGrid = CreatePen(PS_SOLID, 1, &h404040), hPenOld = SelectObject(hdcZoomMem, hPenGrid)
For i As Long = iCell To iZoomW - 1 Step iCell
MoveToEx(hdcZoomMem, i, 0, NULL) : LineTo(hdcZoomMem, i, iZoomW)
MoveToEx(hdcZoomMem, 0, i, NULL) : LineTo(hdcZoomMem, iZoomW, i)
Next
'highlight the center pixel (the one that gets picked)
Dim As HPEN hPenSel = CreatePen(PS_SOLID, 2, &h0000FF) 'BGR: red
SelectObject(hdcZoomMem, hPenSel)
SelectObject(hdcZoomMem, GetStockObject(NULL_BRUSH))
Rectangle(hdcZoomMem, iHalf * iCell - 1, iHalf * iCell - 1, (iHalf + 1) * iCell + 2, (iHalf + 1) * iCell + 2)
'hex bar: current pixel color as background, hex code with luma based text color
Dim As Ulong bgr_ = GetPixel(hdcScr, pt.x, pt.y)
Dim As Long r = bgr_ And &hFF, g = (bgr_ Shr 8) And &hFF, b = (bgr_ Shr 16) And &hFF
Dim As Ulong iRGB = r Shl 16 Or g Shl 8 Or b
Dim As HBRUSH hBrushBar = CreateSolidBrush(bgr_)
Dim As RECT rc : rc.left = 0 : rc.top = iZoomW : rc.right = iZoomW : rc.bottom = iZoomH
FillRect(hdcZoomMem, @rc, hBrushBar)
SetBkMode(hdcZoomMem, TRANSPARENT)
SetTextColor(hdcZoomMem, Iif(0.299 * r + 0.587 * g + 0.114 * b < 128, &hFFFFFF, &h000000))
Dim As HFONT hFontOld = SelectObject(hdcZoomMem, hFont)
Dim As String sHex = "#" & Hex(iRGB, 6)
DrawText(hdcZoomMem, sHex, -1, @rc, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
SelectObject(hdcZoomMem, hFontOld)
'flip backbuffer to the lens window
Dim As HDC hdcWnd = GetDC(hZoom)
BitBlt(hdcWnd, 0, 0, iZoomW, iZoomH, hdcZoomMem, 0, 0, SRCCOPY)
ReleaseDC(hZoom, hdcWnd)
SelectObject(hdcZoomMem, hPenOld)
DeleteObject(hPenGrid) : DeleteObject(hPenSel) : DeleteObject(hBrushBar)
ReleaseDC(0, hdcScr)
End Sub
Function WndProc(hWnd As HWND, wMsg As Uint, wParam As WPARAM, lParam As LPARAM) As LRESULT
Select Case hWnd
Case hGUI
Select Case wMsg
Case WM_DESTROY
PostQuitMessage(NULL)
Return 0
Case WM_DPICHANGED 'DPI: resize to the suggested rect (height clamped to 87% of work area) + re-layout
Dim As RECT Ptr prc = Cast(RECT Ptr, lParam)
Dim As Long nx = prc->left, ny = prc->top, nw = prc->right - prc->left
Dim As Long nh = MulDiv(725, Loword(wParam), 96) 'Basis-Höhe frisch fürs neue DPI
Dim As HMONITOR hMon = MonitorFromWindow(hGUI, MONITOR_DEFAULTTONEAREST)
Dim As MONITORINFO tMI : tMI.cbSize = Sizeof(tMI)
If GetMonitorInfo(hMon, @tMI) Then
Dim As Long iMaxH = (tMI.rcWork.bottom - tMI.rcWork.top) * maxGUIHeight
If nh > iMaxH Then nh = iMaxH
End If
SetWindowPos(hGUI, NULL, nx, ny, nw, nh, SWP_NOZORDER Or SWP_NOACTIVATE)
ApplyLayout(Loword(wParam))
Return 0
Case WM_SYSCOMMAND
Select Case Loword(wParam)
Case id_About
MessageBox(hGUI, sTitle, "About", MB_OK Or MB_ICONINFORMATION Or MB_TOPMOST)
Return 0
End Select
Case WM_COMMAND
Select Case lParam
Case hButton_exit
DestroyWindow(hGUI)
Return 0
Case hCheckbox
bChkBox = Iif(IsDlgButtonChecked(hWnd, 2), TRUE, FALSE)
Return 0
Case hCheckbox2
bChkBox2 = Iif(IsDlgButtonChecked(hWnd, 3), TRUE, FALSE)
Return 0
Case hButton_pick 'Feature: pick color from dialog -> select nearest named color
Dim As Boolean bOk
Dim As Ulong iRGB = ChooseRGB(bOk)
If bOk Then SelectNearest(iRGB)
Return 0
Case hButton_screen 'Feature: pick color from screen with zoom lens
StartPicking()
Return 0
Case hInput
If Hiword(wParam) = EN_CHANGE Then
Dim As Long iLen = GetWindowTextLength(hInput)
Dim As ZString * 255 sInput
If iLen > 0 Then GetWindowText(hInput, sInput, iLen + 1)
sCurFilter = sInput
RefreshList(sCurFilter)
End If
Return 0
End Select
Case WM_CTLCOLOREDIT
If lParam = hInput Then
Static As HBRUSH hBrushWhite = 0, hBrushRed = 0
If hBrushWhite = 0 Then hBrushWhite = CreateSolidBrush(&hFFFFFF)
If hBrushRed = 0 Then hBrushRed = CreateSolidBrush(&h0000FF) 'BGR
Dim As Boolean bHit = SendMessage(hListView, LVM_GETITEMCOUNT, 0, 0) > 0
Dim As HDC hdcStatic = Cast(HDC, wParam)
SetTextColor(hdcStatic, &h000000)
SetBkColor(hdcStatic, Iif(bHit, &hFFFFFF, &h0000FF))
Return Cast(LRESULT, Iif(bHit, hBrushWhite, hBrushRed))
End If
Return 0
Case WM_TIMER
If bPicking And wParam = 1 Then
If GetAsyncKeyState(VK_LBUTTON) And &h8000 Then 'pick (works even if the capture got lost)
Dim As POINT pt : GetCursorPos(@pt)
Dim As HDC hdcScr = GetDC(0)
iPickedBGR = GetPixel(hdcScr, pt.x, pt.y)
ReleaseDC(0, hdcScr)
StopPicking()
Dim As Ulong iRGB = (iPickedBGR And &hFF) Shl 16 Or (iPickedBGR And &hFF00) Or (iPickedBGR Shr 16) And &hFF
SelectNearest(iRGB)
Else
UpdateZoom()
End If
Return 0
End If
Case WM_MOUSEMOVE
If bPicking Then
UpdateZoom()
Return 0
End If
Case WM_LBUTTONDOWN
If bPicking Then
Dim As POINT pt : GetCursorPos(@pt)
Dim As HDC hdcScr = GetDC(0)
iPickedBGR = GetPixel(hdcScr, pt.x, pt.y)
ReleaseDC(0, hdcScr)
StopPicking()
Dim As Ulong iRGB = (iPickedBGR And &hFF) Shl 16 Or (iPickedBGR And &hFF00) Or (iPickedBGR Shr 16) And &hFF
SelectNearest(iRGB)
Return 0
End If
Case WM_RBUTTONDOWN
If bPicking Then
StopPicking()
Return 0
End If
Case WM_SETCURSOR
If bPicking Then
SetCursor(LoadCursor(NULL, IDC_CROSS))
Return TRUE
End If
Case WM_KEYDOWN
Select Case wParam
Case VK_ESCAPE
If bPicking Then
StopPicking()
Return 0
End If
DestroyWindow(hGUI)
Return 0
End Select
Case WM_NOTIFY
Dim As NMHDR Ptr pNMHDR = Cast(NMHDR Ptr, lParam)
Select Case pNMHDR->hwndFrom
Case hListView
Select Case pNMHDR->Code
Case LVN_COLUMNCLICK 'Feature: sort by column click
Dim As NMLISTVIEW Ptr pNMLV = Cast(NMLISTVIEW Ptr, lParam)
SortTable(pNMLV->iSubItem)
Return 0
Case LVN_KEYDOWN
Dim As NMLVKEYDOWN Ptr pKeyDown = Cast(NMLVKEYDOWN Ptr, lParam)
If pKeyDown->wVKey = VK_RETURN Then
Dim As Long iSelectedItem = SendMessage(hListView, LVM_GETNEXTITEM, -1, LVNI_SELECTED)
If iSelectedItem <> -1 Then
Dim As NMITEMACTIVATE tNMIA
With tNMIA
.hdr.hwndFrom = hListView
.hdr.idFrom = GetDlgCtrlID(hListView)
.hdr.code = NM_DBLCLK
.iItem = iSelectedItem
.iSubItem = 0
.ptAction.x = 0
.ptAction.y = 0
End With
SendMessage(hGUI, WM_NOTIFY, 0, Cast(LPARAM, @tNMIA))
End If
End If
Case NM_DBLCLK
Dim As NMITEMACTIVATE Ptr pNMIA = Cast(NMITEMACTIVATE Ptr, lParam)
Dim As ZString * 255 sHexColor, sName
Dim tLV_item As LV_ITEM
With tLV_item
.mask = LVIF_TEXT
.iItem = pNMIA->iItem
.iSubItem = 1
.pszText = Strptr(sHexColor)
.cchTextMax = 255
End With
If tLV_item.iItem <> -1 Then
SendMessage(hListView, LVM_GETITEM, 0, Cast(LPARAM, @tLV_item))
If bChkBox2 Then sHexColor = "FF" & sHexColor
If bChkBox Then sHexColor = "&h" & sHexColor
If OpenClipboard(hGUI) = 0 Then
MessageBox(hGUI, "Error opening the clipboard", "ERROR", MB_OK)
Else
If EmptyClipboard() = 0 Then
CloseClipboard()
MessageBox(hGUI, "Error cleaning the clipboard", "ERROR", MB_OK)
Else
Dim As HGLOBAL hMemClip = GlobalAlloc(GMEM_MOVEABLE Or GMEM_SHARE, Len(sHexColor) + 1)
Dim As Any Ptr pMemClip = GlobalLock(hMemClip)
CopyMemory(pMemClip, Strptr(sHexColor), Len(sHexColor) + 1)
GlobalUnlock(hMemClip)
If SetClipboardData(CF_TEXT, hMemClip) = 0 Then
GlobalFree(hMemClip) 'only free on failure
CloseClipboard()
MessageBox(hGUI, "Error setting clipboard data", "ERROR", MB_OK)
Else
CloseClipboard()
tLV_item.iSubItem = 0
tLV_item.pszText = Strptr(sName)
SendMessage(hListView, LVM_GETITEM, 0, Cast(LPARAM, @tLV_item))
MessageBox(hGUI, "Hex color value " & sHexColor & " (" & sName & ") has been copied to clipboard.", "Information", MB_ICONINFORMATION Or MB_OK)
End If
End If
End If
End If
Return 1
Case NM_CUSTOMDRAW
Dim As NMLVCUSTOMDRAW Ptr pCustomDraw = Cast(NMLVCUSTOMDRAW Ptr, lParam)
Select Case pCustomDraw->NMCD.dwDrawStage
Case CDDS_PREPAINT
Return CDRF_NOTIFYITEMDRAW
Case CDDS_ITEMPREPAINT
Return CDRF_NOTIFYSUBITEMDRAW
Case CDDS_ITEMPREPAINT OR CDDS_SUBITEM 'thanks to Velted for the code
Dim As Long bIsSelected = SendMessage(hListView, LVM_GETITEMSTATE, pCustomDraw->nmcd.dwItemSpec, LVIS_SELECTED)
If bIsSelected Then pCustomDraw->nmcd.uItemState = pCustomDraw->nmcd.uItemState And Not(CDIS_SELECTED)
Select Case pCustomDraw->iSubItem
Case 0 To 1
pCustomDraw->ClrText = Iif(bIsSelected, &hFFFFFF, 0)
pCustomDraw->ClrTextBk = Iif(bIsSelected, &hCC6600, &hFFFFFF)
Case 2
pCustomDraw->ClrText = &h000000
Dim As ZString * 255 sText
Dim tLV_item As LV_ITEM
With tLV_item
.mask = LVIF_TEXT
.iItem = pCustomDraw->NMCD.dwItemSpec
.iSubItem = 1
.pszText = Strptr(sText)
.cchTextMax = 255
End With
SendMessage(hListView, LVM_GETITEM, 0, Cast(LPARAM, @tLV_item))
pCustomDraw->clrTextBk = BGR(Valint("&h" & Left(sText, 2)), Valint("&h" & Mid(sText, 3, 2)), Valint("&h" & Right(sText, 2)))
End Select
Return CDRF_NEWFONT
End Select
End Select
Return CDRF_DODEFAULT
End Select
End Select
End Select
Return DefWindowProc(hWnd, wMsg, wParam, lParam)
End Function
Function ChooseRGB(Byref bOk As Boolean) As ULong
Dim As CHOOSECOLORW tCC
Static As Ulong aBGR(15) 'static: keep custom colors between calls
With tCC
.hInstance = Null
.hwndOwner = hGUI
.lStructSize = Sizeof(tCC)
.lpCustColors = @aBGR(0)
.rgbResult = Rgb(0, 0, 255)
.Flags = CC_ANYCOLOR Or CC_RGBINIT Or CC_FULLOPEN
End With
bOk = Iif(ChooseColorW(@tCC), TRUE, FALSE)
Return (tCC.rgbResult And &hFF) Shl 16 Or (tCC.rgbResult And &hFF00) Or (tCC.rgbResult And &hFF0000) Shr 16 'BGR to RGB
End Function
'LV Function taken from https://www.freebasic.net/forum/viewtopic.php?f=6&t=17060
Function LV_InsertColumn( Byval hWndControl As HWND, _
Byval iPosition As Integer, _
Byref sString As String, _
Byval nAlignment As Integer = LVCFMT_LEFT, _
Byval nWidth As Integer = 100 _
) As Integer
Dim tlvc As LV_COLUMN
If IsWindow(hWndControl) Then
tlvc.mask = LVCF_FMT Or LVCF_WIDTH Or LVCF_TEXT Or LVCF_SUBITEM
tlvc.fmt = nAlignment
tlvc.cx = nWidth
tlvc.pszText = Strptr(sString)
tlvc.iSubItem = 0
Function = SendMessage( hWndControl, LVM_INSERTCOLUMN, iPosition, Cast(LPARAM, @tlvc))
End If
End Function
Function LV_InsertItem( Byval hWndControl As HWND, _
Byval iRow As Integer, _
Byval iColumn As Integer, _
Byref sString As String, _
Byval lParam As Integer = 0, _
Byval iImage As Integer = 0 _
) As Integer
Dim tLV_item As LV_ITEM
If IsWindow(hWndControl) Then
tLV_item.iItem = iRow
tLV_item.iSubItem = iColumn
tLV_item.pszText = Strptr(sString)
tLV_item.iImage = iImage
tLV_item.lParam = lParam
If iColumn = 0 Then
tLV_item.mask = LVIF_TEXT Or LVIF_PARAM Or LVIF_IMAGE
Function = SendMessage( hWndControl, LVM_INSERTITEM, 0, Cast(LPARAM, @tLV_item))
Else
tLV_item.mask = LVIF_TEXT Or LVIF_IMAGE
Function = SendMessage( hWndControl, LVM_SETITEM, 0, Cast(LPARAM, @tLV_item))
End If
End If
End Function
'https://msdn.microsoft.com/en-us/library/windows/desktop/hh298368(v=vs.85).aspx
Function _WinAPI_CreateToolTip(hDlg As HWND, sToolTipText As String, bBalloon As Ubyte = 1, iWidth As Ushort = 500, toolID As Integer = 0) As HWND
If hDlg = 0 Or Len(sToolTipText) = 0 Then Return 0
Dim hToolTip As HWND
bBalloon = Iif(bBalloon > 1, 1, bBalloon)
Dim As Long iStyle = bBalloon * TTS_BALLOON
hToolTip = CreateWindowEx(Null, TOOLTIPS_CLASS, NULL, _
TTS_NOPREFIX Or TTS_ALWAYSTIP Or iStyle, _
CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
hDlg, Null, Null, Null)
If hToolTip = 0 Then Return 0
SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOACTIVATE)
SendMessage(hToolTip, TTM_SETTIPBKCOLOR, &hFFFFFF, 0)
SendMessage(hToolTip, TTM_SETTIPTEXTCOLOR, &h000000, 0)
SendMessage(hToolTip, TTM_SETMAXTIPWIDTH, 0, iWidth)
Dim As HWND hwndTool = GetDlgItem(hDlg, toolID)
Dim tToolInfo As TOOLINFO
With tToolInfo
.cbSize = Sizeof(tToolInfo)
.uFlags = TTF_SUBCLASS Or TTF_IDISHWND
.hwnd = hDlg
.uId = Cast(UINT_PTR, hDlg)
.lpszText = Strptr(sToolTipText)
End With
SendMessage(hToolTip, TTM_ADDTOOL, 0, Cast(lPARAM, @tToolInfo))
Return hToolTip
End Function
'Original code by D.J.Peters
Function Base64Decode(sString As String, Byref iBase64Len As Uinteger) As Ubyte Ptr
#Define P0(p) InStr(B64, Chr(sString[n + p])) - 1
Dim As String * 64 B64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim As String sDecoded
Dim As Integer nChars = Len(sString) - 1
If nChars < 0 Then Return 0
For n As Integer = 0 To nChars Step 4
Var b = P0(1), c = P0(2), d = P0(3)
If b >-1 Then
Var a = P0(0)
sDecoded += Chr((a Shl 2 + b Shr 4))
End If
If c > -1 Then sDecoded += Chr((b Shl 4 + c Shr 2))
If d > -1 Then sDecoded += Chr((c Shl 6 + d ))
Next
iBase64Len = Len(sDecoded)
'workaround For multiple embedded file other crash will occure
Static As Ubyte aReturn(0 To iBase64Len - 1)
Redim aReturn(0 To iBase64Len - 1) As Ubyte
For i As Uinteger = 0 to Len(sDecoded) - 1
aReturn(i) = Asc(sDecoded, i + 1)
Next
Return @aReturn(0)
End Function
'Code below was generated by: FB File2Bas Code Generator v1.01 build 2020-02-27 beta
'ColorConstants.txt
__Label0:
Data 12,8,6733,4346,"Base64"
Data "QsAGYTAGa7ADMGAQB9EACuAEaXAGaEAHBTEEMJADMBAECXEEdeAGbVAGdBAGbLADMjAEM1ADM5ADCdEEaUAGbsAQDvERQhADLnEDCTEEaBAGcjAGb9AROzADNCADOAASCUEENbEGIDAFAUEHZQACRyAHZZAHHzESODADQ5AQT5AGHjEDQjADMZAVCQEQAjEUQxAGD0EDWgEVJaEASSAHKJEGddAGOkEEUTEDFaEAXTEQIFAEZeARNGADM1AEM2AEXBEQdTEEb3AHO0ADQ6AXemERchAGeQACV/AGbGAGO1ADMEADQUADQpAQVhAGbQAHabAUScEYTVEDNlAZNRADi9EYIEAEkQEHaJAGbkAZQ1ADOFAbMlETYvAGbiAajbEDNiADNUAEwpEQQTAHaNAbTWEDyzEDwCETbPAGdUAGjqEUvmEDRGADOWADOJAQU9AGb7AGTJEcO3ADMmADRXAdqtEUN9AcRnAeqqESR7EDUHEDRXADUjEXYUEH"
Data "bFAGx5EGcDAeOEADAuIT6gECQwAd0rEDQmADDCIENGAgR/AGbzAHZbADRBADRAADQ1AECQEFRhEbbLEDRVADRUADRSADJrERHcEGaTAGRFEVdlAGcrAgQzAENmAjgFEHSFEdTZEDOBAERjAEMaEATLASdEAURsEjo/EbRHADQoADRNAdSjIepsEeUJEQSrARVRID11EfJpEGc4AkALEjv6EXTtIhCtAEucEfIEAmFlIaXpImRREWSPEm5DED9xEEqaEAU3AUeOEmbFAmA7IXQQADOoIUSuAbMiAENUADX6IAQSEHQ0EnRxEoZcIoM2AbNgAmKXEkl2IhMYAajQIhChEGduAYd3IQMIADhzIXgoIUV0AT/KETPIEmCcEEYfAZcwAqOyAqWQEpRFAGKtEGrCEUvSIqLxElCVEENUEHyKEqB2EoMvEGYtARYwIrBQEDMrAhKfIqOyIGMyIHqZItBjEWQ+AtU6ArrwEadpItweEoQ4IodpEH/eEr"
Data "pZED8qIAUvAGedARvcIoNgADRJAmbwICT2ATsEEGvmIENFADQjIvTPAGdFAHc/Ab2gEDRYAfRtIQSFIp7lIm7GEDQfIXCnAFsUEGhMErdyIS9aEvRxAYafAvBpMEY2AhzYEDQjAEfDIFVTEUdzIgQKIvNIMqOiERG0IkBrMEb5AGv1EDOaAxRDIYgtIGYiAzvYIDNxAkQxMGYkAuZZIDNSAE+UIkHOMQRPEnbNAr5YEDQpImT2AzYcAbdxIwJYIfBiMFaSAGuiEbMwAD52EEJWMwRLAUc2AxonIDBIMfrUEGZzAjyFIbORA41CIHbmAG0HEHj3MnNkADYVMEUtIna/A1FrIcPzI5c1EHdHAUcnA5o6MTQqMxCVEzZRAucnAGlDEydiMT4yImM5MtNTAEWHE6wlIGADIFotMrVzE2wzMsaVAsd3IDOSAEQRA7RfIpx+M6PjEEQSIXQeEY2IM1IEEyWVIGcrMy2WIoQ2AE1WMwQeAGjuMRQnAf"
Data "RVA9UBAGYgIod/Ig6lM9U1A+vYIuRBA4JQMFhEEGmpMtN0IwpzMYjKE2dxIkRMAhG/MpEEQEAnQ6/GI1vFEEZ3AGvSIEBINBHtIRIIMURsIGTcE/E4QrnzIE/iIbRQADA1QyV1AnNFIEQtAwRiAXQdAiNnMnRjBDbVMyQaAHdbAUOyBENNRCHZMkdbIDNsJE1uNEQRAHddAZNREbFpIDfrE+3KEARcAfY0AHafEid5IDQVIEp2NFWNQGWuQGFnIDA0QEpfJCcgMCbyAHINBGYaAtU0QFcrAbayNAAlQwsAICWgAaNyEbNTBHayQ4iJQrZzAhsoED9CME1TMEeNEf8lEZOcQ+iEQEMvMdbrAwJ4Ii1UMFaWAGZiA32ZMhUeIqd8QbTwAHYXBFXAQS95E0iIQEFMIR5PEkQkIkTqBHzzIjvGE2dHA+IYMDQ6IvTVAGZLAWxUIFSHRFTFMhhvFMNgI61yQH2RQmFkIDUXEdmqEAWsIGKWQGYYIG"
Data "hoEjvDQvZ7AUw0IeOhM8NWASAhEGdwAqolEG9lROOqQvy0QU/6MUAdU3RRAEOSA5QHEs4CRO23QV+ZIv3fE/4LQfS6JQhqEpRNAqKkJNbMFHV5RFaRFHtZI1OMAnCdU8x5E8MJA4kNIj7gQCElUH2gQn9nErcxFQGwVQAjUkWZMmVFA+HmEQrRJSfYJQ9SQbJ4IDOXAD+qQAYPEddXA5YeA4QSUbN4ADOLAc6KQuW+VSljQgYhA9CYEEYaAHgFJWvxED93EbCmAFw/IGxfJWbBMRrmIEycRVv2ED92EeEDUpIGAEetRJfxUcYxFXIlVNBxUGf+U3geUojkVSh1U4SPJWO1EeIoFR/RRQZPBX5XQfjaUAULBFkpU1iFEqSoARZ9Amm/Uo6IIfU0ATbSBIdSFbpUUk0jRSxTIFcIBSHyRbrWJamJVYb3UiORAcYFRWB6MSu/EbQbAnMsAzwhUbxOVUhkFd20JBGjFaMRAEwPIcbyAje7RZDAUD"
Data "NUBVzzUFbhAG4fEbwYMV+OFDaTAsf4UjiGFazxUEcAAHtHIY/EUkWYAXmPNXNSADGmJaS3Bg1LFdA8Ze3qIFd2U1HGVP8eJIfGIEgqRdHeVQN3JJi6FQIAAF5WMxURUSwAMUkREQeyQEVaE2b2UbQsAgVCUplNJUHZUzWMFSsnMGWARff5UvQiBTfBIEdvAGYxAGKfNXQgASMjAgHhImHDEGsPEGRCZB3GIW6hIQovVWezIEXURVSMAWbZBdViMHYLZdj8RSxUQ7dRAQCQY1b9YddPAGAfYpEpJg9aEdpeJDZxAGGCYbnFMEP8Ip6dRkhEYZa8QgafJWBhE4BsEsGuFAbNZRD2MEMIEr/cQbNDZHN2BaM+EsS1ExFgIkm2ZahKNVg/RWI7NpzAUmboAk9ARiRPQjJJZfVIAGbCEGC1Ii1CUXBqUoBxRFfkEEUJIQRhVZbyVFjQI6z2Vg60QYCxIDqkYkReE8jKYzh1ZZCiAhbHBAbiBIC/M5"
Data "RBAEN1AqayUHMiImSREZ5kYwMjBV3YERIDBtmKNEX3QfCZFv1UZDlFZVesQb/1YYA6QprmI/CaMRtLZvgYMuu1M+bUFDOVIkZVBKBwIbrSRdA/RMidZAbjAHPvNwUXI3ZcAQFmIEDyMcdwMdpqRyOnQdZuE+dJAGuSQraSAfPJRDTiITt3VLZ5BSRlAf8wMYcnNl0+RDpbQwgZNDQwA6nKES6+RHRsAXNRAE6EQFeCQEgnQHMcQhYpNoJyYQ7+R0YlMqTVAxHLFm+5ZscyUFdbA3j0MEdTAQjmFwbmdcXJEWThRuTXdBMNBf8ZZfYuB1MRQEO2Naa8JkgqQSICA3ojUTAbVNRsAoDJJo6tJKjqdENpYDpiUEAUUjm+YSoyY3HJEgcKByPAQcghNQ+HZg1XZoWQd6h0cUdSBoOCQD6WYDgoNEKQQZb7AwBAMlWQMUAQUgZHdl+xY8mGER2aU5hxdF0oMe6XJlE/JAFQN71FYYRQAk5NUnkZcq"
Data "0kc/aUQDoGMELAICTFA+ZuAm0jcEOVMaroIwckNW8XYhlyF42RZ5UcQoPTFLE7IG+PV+hCEbQzJepscYGuERIlYEtXc/FtMoQcA53rIENDGAOxAE6KYdaWJVgGJ4BhhFMZBGDcJ3u9FWUeQkVuctq+Q4e1R/72Mh8cdSYyETsQFfpRRFkQN6csYfHoMGB6aBRiA9AkNYQ/F3w1JuQ+hVo5ZnqkcjUMIeMzADCRF8C6MdvUeFUxFfBfh18/E3qNFbS8ZkI2dJ9FYWxSEHbTB+IugTT2KE4WdKYrIbcgRWw1EyTbBkNGEYXUQEg6UAW1cHqsdNcOEtg9FKAfUbDdMXSWN7oVcT8yESIYFOUjBNrAEaDzFHCmZa/vMZfjRHevETChCDW+VlOogY6oYaCRF3YnJswGGD+3KJh4UHx1Ybo4YGSxYZUBR/WNeJ07QbfmQjyyFw9nNL/nIwjCGDI1IaokYka8V9JVaKFoIeODKKUMAWcDCAtaSMjqNE"
Data "WWNdUrMbYiIHdmdzgzQYcZSM9qdyWVNOPIMRaVEh67iM6KGKfLIm75Nl07hvrUIDrpJj9OiNRvBV+0c5ORE4m+gqQnA/4TEm6sePBMlSc2VQp9hxDhVWy8aOKEWNXkWBfBKQFhlDMZAzJkhFZ9NAOWEf6iZqXFE+vGGJTTdVw2EWnMEftJZaMcmMjrKKfZKLA5FdAkmN7FVfrDhN+7Yq3dF4P7hvUiZwcec1IKCT7iED4ZgQfSUHjJEWUnmURDcw4nWV7WIX75OTXQkcdlYkpxJZOmkiVWlaEiMjXGluY8Fp4MYYqmcG5ahzFxISLFUykycmbpA6cnlslzGKk5eVjqGT6JIY+BgGuShobqBCloEQVQUb65QGJlY8UDiCLzFqylg747IDknMQJROTj7FFozkRguctQoBEQWZKTfFMBgGWltlJgvkQYeMwnvUqEyJaOlkfItGJ+OUG8DUfmBEDnWh/aQGKfYGWRtAuhuciBNEq67V4NVFJ8xED"
Data "6xWLH0JSqCVHGuIofFJXbCAjSLImgiRdwekooOOdxVKe50ke4qlgrEghjgGdbrB8oUgi3oKNNkMeKxcEc1V362RiSBRgcrRywQE6/DIHbfiFPjYgfHKB8ZWZDjqDT8MqaYJabvAz1YYYLBVVLQQHYjKdJhYbBBGi0VOF+0Ih1Agk6CYXGApv4jYiNgI8ANkfM+Ix/fc5YxYkVPZBHUoQRnBB9WFHE4NnvAEWsalEUDdAVOahbiJ3YhBbIhI4hQQ6JyEmivminWdjYyOlRUpdm5YmBkWkSlSm03OVAYFm+oiiHqpEafQkCpeiUvml9rEnRjamxhImTWEfDjVeuEFNVPciaeqc1OWBNQFf58gbaUp0HsknZAJTbFkah7ZuExOnRUqMWWeFN8SAgwSpN9KLm5EGkbElU7kXtdE9yLepSqRgX0UkRHogg8hk8mUiJZID7nmn7FdKizYiPLFaCeEEZSCqKQqrIkFd++Q4tFZ1QjRDJTNK3yEHrzEx"
Data "QchkILAmzRpMfZEVu8p3n1KsxyqnDUOFp2M/bWIFp/qDhIkhpmF8gShn//Gq6IJ1/aYm0/RY64qqSLKYQVCVJskvQYYUabozPZEdXIFEtFavMRCwSXM/aGAGclavwdETLRqQYFE5YXGqj4qsB3uxHkI1C9JFUFIy/Dpn2FittFIftQEpKpugIIAWYUIZoiY/HEo1B7qycEIfTyM7psQQb2AYRsYq/omgbaKHIrc68PQSL3u0SLFWKXgimgIpHXQGAXZ6cPWPPVkdhFgiWLdUMNsmitIWI9MTwXIsCHNlKDGfTcuhT2tYmDMjGqhuiddb+kpSaqswC2IZ8uchcBsEGvEseeCK1ihBRBKQKLsR82ErHGKq/Tofb/FMZiG2SDFWdlIx76Q1LVc25oUXjlG5Aaop9fO089EXJVJEenAUV6azCTofJXs6vvVYoSsggeVzijYHb1qwpQuwV0G6O2ssHFeofDsWp0MFecCcj1q6iIF1mpRb2he6n1ce"
Data "vxuzJ/Edc+BHUDNMJYMEeHGqZZRnu7uz+dd6f5kWbTAH0oUio4sflcsajEFJB8i+ZVMVAhFFQAISYESpyIGoIwM1+LEmdSAjIwIDRnY6J4M/zNm6tHIj1DM00GE4d/WqRCg/xgsbYkIrfzg2b+EhM5IGd5CitHJoK9RpMgJze9ShZIhlIxJC81bCw3JAe2SlZdIXJsJDHVwTHmGk9NMwn2VbQjhAJZImJ8EGQ5FzO7dG6lNDsLFzNFQy/w8="
|
Die App ist noch in der Entwicklung...
_________________
Gruß
UEZ
Zuletzt bearbeitet von UEZ am 07.07.2026, 18:51, insgesamt 17-mal bearbeitet |
|
| Nach oben |
|
 |
grindstone
Anmeldungsdatum: 03.10.2010
Beiträge: 1296
Wohnort: Ruhrpott
|
| Verfasst am: 25.02.2020, 16:46 Titel: |
|
|
Hallo URZ!
Beim Compilieren bekomme ich die Fehlermeldung:...\FreeBASIC-1_05_0\bin\win32\ld.exe: cannot find -lz Liegt das an meiner veralteten FB-Version (1.05) oder brauche ich noch irgendeine externe Bibliothek?
Ansonsten: Tolles Tool, die Idee könnte glatt von mir sein.   Vielleicht (nur mal als Anregung) könnte man noch einen Farbeditor integrieren?
Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen! |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 148
Wohnort: Opel Stadt
|
| Verfasst am: 25.02.2020, 17:10 Titel: |
|
|
| grindstone hat Folgendes geschrieben: | Hallo URZ!
Beim Compilieren bekomme ich die Fehlermeldung:...\FreeBASIC-1_05_0\bin\win32\ld.exe: cannot find -lz Liegt das an meiner veralteten FB-Version (1.05) oder brauche ich noch irgendeine externe Bibliothek?
Ansonsten: Tolles Tool, die Idee könnte glatt von mir sein. Vielleicht (nur mal als Anregung) könnte man noch einen Farbeditor integrieren?
Gruß
grindstone |
Hallo grindstone,
danke für dein Feedback. Ich dachte, dass die ZLib standardmäßig dabei ist, aber anscheinend doch nicht.
Im 1. Beitrag oben habe ich einen Download Link angeben, wo die benötigten Dateien in dem Zip Archiv hinterlegt sind. Ich hoffe, dass die Dateien vollständig sind.
Farbeditor?!? - hmm, muss ich mir noch überlegen, wie ich ihn integrieren soll.
Hat jemand eine Idee, wie ich bei Verwendung von LVS_EX_FULLROWSELECT verhindern kann, dass die Auswahl der Zeile nicht die letzte Spalte markiert und somit die Farbe überschreibt?
Eine Autoit Lösung habe ich, aber einige Funktionen nach FB zu übersetzen ist nicht ganz trivial...
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
grindstone
Anmeldungsdatum: 03.10.2010
Beiträge: 1296
Wohnort: Ruhrpott
|
| Verfasst am: 26.02.2020, 17:20 Titel: |
|
|
Das Programm will irgendwie nicht. Mit den Dateien von dem angegebenen Link bekomme ich dieselbe Fehlermeldung, und wenn ich die einzige libz.dll, die ich auf dem System habe (von Avidemux), in den Programmodner kopiere, compiliert das Programm und startet auch, aber es erscheint nur das Fenster ohne Farben.
Ich würde gerne einen Screenshot hochladen, aber ich bekomme gerade keine Verbindung zum Server.
Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen! |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 148
Wohnort: Opel Stadt
|
| Verfasst am: 26.02.2020, 18:00 Titel: |
|
|
Ich habe den Inhalt der Datei ColorConstants.txt in den Post#1 hinzugefügt. Wenn du den Inhalt als Datei erstellst, sollten die Farben sichtbar sein.
Ich werde in einer VM FB installieren und testen, warum das Kompilieren nicht funzt.
Funktioniert eigentlich das Zip Archiv mit der bereits kompilierten Exe?
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 148
Wohnort: Opel Stadt
|
| Verfasst am: 27.02.2020, 11:20 Titel: |
|
|
Ich habe jetzt die ZLib Komprimierung durch die Windows interne ersetzt. Jetzt sollte das Problem mit ZLib (zlib1.dll) nicht mehr existieren und die Farbtabelle sollte erstellt werden!
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
Sebastian
Administrator
Anmeldungsdatum: 10.09.2004
Beiträge: 5969
Wohnort: Deutschland
|
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 148
Wohnort: Opel Stadt
|
| Verfasst am: 27.02.2020, 15:47 Titel: Re: LZW-Codec in der Gfxlib |
|
|
| Sebastian hat Folgendes geschrieben: | | UEZ hat Folgendes geschrieben: | | Ich habe jetzt die ZLib Komprimierung durch die Windows interne ersetzt. |
Die FreeBASIC-gfxlib, die sowieso plattformunabhängig eingebunden wird, enthält übrigens auch schon fertige (De-)Kompressions-Routinen (LZW). 
Siehe Unterabschnitt "LZW-Codec in der Gfxlib" unter:
https://www.freebasic-portal.de/befehlsreferenz/tipps-und-tricks-465.html |
Danke für den Tipp. Ich habe jetzt LZW in mein Tool "FB File2Bas Code Generator" integriert, aber wie kann ich das Fenster, das mit Screenres geöffnet wurde, wieder schließen?
Ich weiß, da war was, aber ich kann es momentan nicht finden...
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
Sebastian
Administrator
Anmeldungsdatum: 10.09.2004
Beiträge: 5969
Wohnort: Deutschland
|
|
| Nach oben |
|
|
grindstone
Anmeldungsdatum: 03.10.2010
Beiträge: 1296
Wohnort: Ruhrpott
|
| Verfasst am: 27.02.2020, 16:13 Titel: Re: LZW-Codec in der Gfxlib |
|
|
| UEZ hat Folgendes geschrieben: | | wie kann ich das Fenster, das mit Screenres geöffnet wurde, wieder schließen? |
Bei einem Klick auf das Kreuz liefert INKEY den Wert Chr(255,107).
| Code: | ScreenRes 600,600
Do
Sleep 1
Loop Until InKey = Chr(255,107) |
Alternativ kannst du das Programm auch mit "console" compilieren. Dann verschwindet beim Schließen des Konsolenfensters auch das Screenres - Fenster.
Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen! |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 148
Wohnort: Opel Stadt
|
| Verfasst am: 27.02.2020, 16:47 Titel: Re: #include "fbgfx.bi" |
|
|
| Sebastian hat Folgendes geschrieben: | Wenn du
| Code: | | #include "fbgfx.bi" |
am Anfang einbindest, müsste es auch ohne SCREENRES-Aufruf gehen.
Hat bei mir gerade zumindest geklappt. |
Yep, danke funktioniert ohne Screenres! 
@grindstone: danke für die alternativ Lösung.
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
grindstone
Anmeldungsdatum: 03.10.2010
Beiträge: 1296
Wohnort: Ruhrpott
|
| Verfasst am: 27.02.2020, 17:10 Titel: |
|
|
@UEZ: Das Programm compiliert jetzt, beim Erstellen der Farbtabelle gibt es aber noch Probleme: Beim Erstellen von "ColorConstants.txt" stürzt das Programm mit einer Schutzverletzung ab, hinterlässt aber eine leere Datei. Beim zweiten Start erscheint dann das Fenster, aber ohne Farbwerte. Wenn ich die geposteten Farbwerte in die Datei kopiere, läuft alles einwandfrei.
Das Problem liegt in "pRtlDecompressBufferEx". Die eigentliche Ursache ist aber möglicherweise mein Betriebssystem. Ich benutze (immer noch) XP.
Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen! |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 148
Wohnort: Opel Stadt
|
| Verfasst am: 27.02.2020, 17:36 Titel: |
|
|
| grindstone hat Folgendes geschrieben: | @UEZ: Das Programm compiliert jetzt, beim Erstellen der Farbtabelle gibt es aber noch Probleme: Beim Erstellen von "ColorConstants.txt" stürzt das Programm mit einer Schutzverletzung ab, hinterlässt aber eine leere Datei. Beim zweiten Start erscheint dann das Fenster, aber ohne Farbwerte. Wenn ich die geposteten Farbwerte in die Datei kopiere, läuft alles einwandfrei.
Das Problem liegt in "pRtlDecompressBufferEx". Die eigentliche Ursache ist aber möglicherweise mein Betriebssystem. Ich benutze (immer noch) XP.
Gruß
grindstone |
WindowsXP!?! Daran liegt es wohl, denn laut MS setzt die Funktion RtlDecompressBufferEx mindestens Windows 8 voraus.
¯\_(ツ)_/¯
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
grindstone
Anmeldungsdatum: 03.10.2010
Beiträge: 1296
Wohnort: Ruhrpott
|
| Verfasst am: 27.02.2020, 18:38 Titel: |
|
|
Na, dann hätten wir ja den Übeltäter... 
Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen! |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 148
Wohnort: Opel Stadt
|
| Verfasst am: 28.02.2020, 09:51 Titel: |
|
|
Ich habe jetzt die Komprimierung auf LZW umgestellt, damit auch "ältere" BS die Datei entpacken und erstellen können.
Bitte mal testen!
Danke.
PS: danke an Sebastian für den Hinweis bezgl. LZW Komprimierung.
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
grindstone
Anmeldungsdatum: 03.10.2010
Beiträge: 1296
Wohnort: Ruhrpott
|
| Verfasst am: 28.02.2020, 15:40 Titel: |
|
|
Herzlichen Glückwunsch, jetzt läuft es!
Einige kleine Schönheitsfehler gibt es noch: Der Inhalt des Fensters lässt sich erst dann mit dem Mausrad scrollen, wenn ein Element markiert ist, und die Pfeil- und Bildtasten funktionieren überhaupt (noch) nicht.
Gruß
grindstone
_________________
For ein halbes Jahr wuste ich nich mahl wie man Proggramira schreibt. Jetzt bin ich einen! |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 148
Wohnort: Opel Stadt
|
| Verfasst am: 28.02.2020, 16:12 Titel: |
|
|
Danke für's Testen!
Sobald ich mit der Maus über dem Fenster bin, kann ich per Scrollrad scrollen. Kann sein, dass das ein Feature von dem Maustreiber ist.
Die Tasten muss ich noch coden.
Ich habe auch das Maximieren bzw. GUI Größe ändern herausgenommen.
Ich werde noch ein Color Picker hinzufügen, so dass eine Farbe vom Desktop mit der Maus selektiert werden kann.
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
UEZ
Anmeldungsdatum: 24.06.2016
Beiträge: 148
Wohnort: Opel Stadt
|
| Verfasst am: 08.11.2023, 23:36 Titel: |
|
|
Kleines Update:
* Suchfeld hinzugefügt
* Pfeiltasten bewegen die Selektion
* Enter kopiert den Wert in Zwischenablage
Danke an Velted für die Unterstützung.
Siehe Beitrag #1 für die Details.
_________________
Gruß
UEZ |
|
| Nach oben |
|
|
|
|
Du kannst keine Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum nicht antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
|
|
FAQ
Suchen
Mitgliederliste
Benutzergruppen
Registrieren
Profil
Einloggen, um private Nachrichten zu lesen
Login
