Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing Declares.bas (32.98 KB)
Attribute VB_Name = "mDeclares"
Option Explicit
' rect
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
' font
Public Const LF_FACESIZE = 32
Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
' Owner draw Combo Box stuff:
' Type to hold information about combo items:
Type ICONLISTBOXITEMINFO
lItemData As Long ' Provide item data - normal item data is used to store a pointer to a structure of this type
lExtraData As Long ' An additional item data
lIconIndex As Long ' Index of icon in icon list, if required
lIndentSize As Long ' How far the text should be indented from left, in pixels
lItemHeight As Long ' How high a single item should be
lForeColour As OLE_COLOR ' Fore colour of the item
lBackColour As OLE_COLOR ' Back colour of the item
bUnderLineItem As Boolean ' Whether a ruling should be placed below the item
bOverLineItem As Boolean ' Whether a ruling should be placed above the item
dFontSize As Single ' VB font size, stored here for ease of extracting a font object
tLF As LOGFONT ' API font description. lfFaceName should have all bytes = 0 to use default
lTextAlignX As Long ' Horizonal Text alignment
lTextAlignY As Long ' Vertical Text alignment
End Type
' Windows API stuff
' Owner draw item measure:
Type MEASUREITEMSTRUCT
CtlType As Long
CtlID As Long
ItemId As Long
itemWidth As Long
itemHeight As Long
itemData As Long
End Type
' Owner draw item draw:
Type DRAWITEMSTRUCT
CtlType As Long
CtlID As Long
ItemId As Long
ItemAction As Long
ItemState As Long
hwndItem As Long
hdc As Long
rcItem As RECT
itemData As Long
End Type
' Memory functions:
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
' Memory allocation/manipulation constants:
Public Const GMEM_DISCARDABLE = &H100
Public Const GMEM_FIXED = &H0
Public Const GMEM_INVALID_HANDLE = &H8000
Public Const GMEM_MODIFY = &H80
Public Const GMEM_MOVEABLE = &H2
Public Const GMEM_NOCOMPACT = &H10
Public Const GMEM_NODISCARD = &H20
Public Const GMEM_NOT_BANKED = &H1000
Public Const GMEM_NOTIFY = &H4000
Public Const GMEM_SHARE = &H2000
Public Const GMEM_VALID_FLAGS = &H7F72
Public Const GMEM_ZEROINIT = &H40
Public Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)
' Window style bit functions:
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
' Window Long indexes:
Public Const GWL_EXSTYLE = (-20)
Public Const GWL_HINSTANCE = (-6)
Public Const GWL_HWNDPARENT = (-8)
Public Const GWL_ID = (-12)
Public Const GWL_STYLE = (-16)
Public Const GWL_USERDATA = (-21)
Public Const GWL_WNDPROC = (-4)
' Creating new windows:
Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, 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
' General window styles:
Public Const WS_BORDER = &H800000
Public Const WS_CAPTION = &HC00000 ' WS_BORDER Or WS_DLGFRAME
Public Const WS_CHILD = &H40000000
Public Const WS_CHILDWINDOW = (WS_CHILD)
Public Const WS_CLIPCHILDREN = &H2000000
Public Const WS_CLIPSIBLINGS = &H4000000
Public Const WS_DISABLED = &H8000000
Public Const WS_DLGFRAME = &H400000
Public Const WS_EX_ACCEPTFILES = &H10&
Public Const WS_EX_DLGMODALFRAME = &H1&
Public Const WS_EX_NOPARENTNOTIFY = &H4&
Public Const WS_EX_TOPMOST = &H8&
Public Const WS_EX_TRANSPARENT = &H20&
Public Const WS_GROUP = &H20000
Public Const WS_HSCROLL = &H100000
Public Const WS_MAXIMIZE = &H1000000
Public Const WS_MAXIMIZEBOX = &H10000
Public Const WS_MINIMIZE = &H20000000
Public Const WS_ICONIC = WS_MINIMIZE
Public Const WS_MINIMIZEBOX = &H20000
Public Const WS_OVERLAPPED = &H0&
Public Const WS_POPUP = &H80000000
Public Const WS_SYSMENU = &H80000
Public Const WS_TABSTOP = &H10000
Public Const WS_THICKFRAME = &H40000
Public Const WS_SIZEBOX = WS_THICKFRAME
Public Const WS_TILED = WS_OVERLAPPED
Public Const WS_VISIBLE = &H10000000
Public Const WS_VSCROLL = &H200000
Public Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
Public Const WS_TILEDWINDOW = WS_OVERLAPPEDWINDOW
Public Const WS_POPUPWINDOW = (WS_POPUP Or WS_BORDER Or WS_SYSMENU)
' extended Style:
Public Const WS_EX_CLIENTEDGE = &H200&
Public Const WS_EX_STATICEDGE = &H20000
' Combo box window styles
Public Const CBS_AUTOHSCROLL = &H40&
Public Const CBS_DISABLENOSCROLL = &H800&
Public Const CBS_DROPDOWN = &H2&
Public Const CBS_DROPDOWNLIST = &H3&
Public Const CBS_HASSTRINGS = &H200&
Public Const CBS_NOINTEGRALHEIGHT = &H400&
Public Const CBS_OEMCONVERT = &H80&
Public Const CBS_OWNERDRAWFIXED = &H10&
Public Const CBS_OWNERDRAWVARIABLE = &H20&
Public Const CBS_SIMPLE = &H1&
Public Const CBS_SORT = &H100&
' List box styles:
Public Const LBS_DISABLENOSCROLL = &H1000&
Public Const LBS_EXTENDEDSEL = &H800&
Public Const LBS_HASSTRINGS = &H40&
Public Const LBS_MULTICOLUMN = &H200&
Public Const LBS_MULTIPLESEL = &H8&
Public Const LBS_NODATA = &H2000&
Public Const LBS_NOINTEGRALHEIGHT = &H100&
Public Const LBS_NOREDRAW = &H4&
Public Const LBS_NOTIFY = &H1&
Public Const LBS_OWNERDRAWFIXED = &H10&
Public Const LBS_OWNERDRAWVARIABLE = &H20&
Public Const LBS_SORT = &H2&
Public Const LBS_USETABSTOPS = &H80&
Public Const LBS_WANTKEYBOARDINPUT = &H400&
' Window appearance control:
Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
' Show window styles
Public Const SW_SHOWNORMAL = 1
Public Const SW_ERASE = &H4
Public Const SW_HIDE = 0
Public Const SW_INVALIDATE = &H2
Public Const SW_MAX = 10
Public Const SW_MAXIMIZE = 3
Public Const SW_MINIMIZE = 6
Public Const SW_NORMAL = 1
Public Const SW_OTHERUNZOOM = 4
Public Const SW_OTHERZOOM = 2
Public Const SW_PARENTCLOSING = 1
Public Const SW_RESTORE = 9
Public Const SW_PARENTOPENING = 3
Public Const SW_SHOW = 5
Public Const SW_SCROLLCHILDREN = &H1
Public Const SW_SHOWDEFAULT = 10
Public Const SW_SHOWMAXIMIZED = 3
Public Const SW_SHOWMINIMIZED = 2
Public Const SW_SHOWMINNOACTIVE = 7
Public Const SW_SHOWNA = 8
Public Const SW_SHOWNOACTIVATE = 4
Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Const SWP_SHOWWINDOW = &H40
Public Const SWP_HIDEWINDOW = &H80
Public Const SWP_FRAMECHANGED = &H20 ' The frame changed: send WM_NCCALCSIZE
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_NOCOPYBITS = &H100
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOOWNERZORDER = &H200 ' Don't do owner Z ordering
Public Const SWP_NOREDRAW = &H8
Public Const SWP_NOREPOSITION = SWP_NOOWNERZORDER
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOZORDER = &H4
Public Const SWP_DRAWFRAME = SWP_FRAMECHANGED
Public Const HWND_NOTOPMOST = -2
Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
Declare Function EnableWindow Lib "user32" (ByVal hWnd As Long, ByVal fEnable As Long) As Long
Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hWnd As Long) As Long
Declare Function GetFocus Lib "user32" () As Long
Declare Function MoveWindow Lib "user32" (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
Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Declare Function InvalidateRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT, ByVal bErase As Long) As Long
Declare Function IsWindow Lib "user32" (ByVal hWnd As Long) As Long
' Window relationship functions:
Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Declare Function GetParent Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Public Const GW_CHILD = 5
Public Const GW_HWNDFIRST = 0
Public Const GW_HWNDLAST = 1
Public Const GW_HWNDNEXT = 2
Public Const GW_HWNDPREV = 3
Public Const GW_MAX = 5
Public Const GW_OWNER = 4
' Message functions:
Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Declare Function SendMessageByLong Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
' Key functions:
Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
' ImageList functions:
' Draw:
Declare Function ImageList_Draw Lib "COMCTL32.DLL" ( _
ByVal hIml As Long, _
ByVal i As Long, _
ByVal hdcDst As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal fStyle As Long _
) As Long
Public Const ILD_NORMAL = 0
Public Const ILD_TRANSPARENT = 1
Public Const ILD_BLEND25 = 2
Public Const ILD_SELECTED = 4
Public Const ILD_FOCUS = 4
Public Const ILD_MASK = &H10&
Public Const ILD_IMAGE = &H20&
Public Const ILD_ROP = &H40&
Public Const ILD_OVERLAYMASK = 3840
Declare Function ImageList_GetImageRect Lib "COMCTL32.DLL" ( _
ByVal hIml As Long, _
ByVal i As Long, _
prcImage As RECT _
) As Long
' Messages:
Declare Function ImageList_DrawEx Lib "COMCTL32" (ByVal hIml As Long, ByVal i As Long, ByVal hdcDst As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal rgbBk As Long, ByVal rgbFg As Long, ByVal fStyle As Long) As Long
Public Const CLR_NONE = -1
' GDI object functions:
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Public Const BITSPIXEL = 12
Public Const LOGPIXELSX = 88 ' Logical pixels/inch in X
Public Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
' System metrics:
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Public Const SM_CXICON = 11
Public Const SM_CYICON = 12
Public Const SM_CXFRAME = 32
Public Const SM_CYCAPTION = 4
Public Const SM_CYFRAME = 33
Public Const SM_CYBORDER = 6
Public Const SM_CXBORDER = 5
Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
' Pen functions:
Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Public Const PS_DASH = 1
Public Const PS_DASHDOT = 3
Public Const PS_DASHDOTDOT = 4
Public Const PS_DOT = 2
Public Const PS_SOLID = 0
Public Const PS_NULL = 5
' Brush functions:
Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Declare Function GetSysColorBrush Lib "user32" (ByVal nIndex As Long) As Long
Declare Function InflateRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long) As Long
' Line functions:
Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Type POINTAPI
X As Long
Y As Long
End Type
Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As Long
' Colour functions:
Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Public Const OPAQUE = 2
Public Const TRANSPARENT = 1
Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Public Const COLOR_ACTIVEBORDER = 10
Public Const COLOR_ACTIVECAPTION = 2
Public Const COLOR_ADJ_MAX = 100
Public Const COLOR_ADJ_MIN = -100
Public Const COLOR_APPWORKSPACE = 12
Public Const COLOR_BACKGROUND = 1
Public Const COLOR_BTNFACE = 15
Public Const COLOR_BTNHIGHLIGHT = 20
Public Const COLOR_BTNSHADOW = 16
Public Const COLOR_BTNTEXT = 18
Public Const COLOR_CAPTIONTEXT = 9
Public Const COLOR_GRAYTEXT = 17
Public Const COLOR_HIGHLIGHT = 13
Public Const COLOR_HIGHLIGHTTEXT = 14
Public Const COLOR_INACTIVEBORDER = 11
Public Const COLOR_INACTIVECAPTION = 3
Public Const COLOR_INACTIVECAPTIONTEXT = 19
Public Const COLOR_MENU = 4
Public Const COLOR_MENUTEXT = 7
Public Const COLOR_SCROLLBAR = 0
Public Const COLOR_WINDOW = 5
Public Const COLOR_WINDOWFRAME = 6
Public Const COLOR_WINDOWTEXT = 8
Public Const COLORONCOLOR = 3
' Icon functions:
Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long
Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Boolean
Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Public Const LR_LOADMAP3DCOLORS = &H1000
Public Const LR_LOADFROMFILE = &H10
Public Const LR_LOADTRANSPARENT = &H20
' Blitting functions
Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Const SRCAND = &H8800C6
Public Const SRCCOPY = &HCC0020
Public Const SRCERASE = &H440328
Public Const SRCINVERT = &H660046
Public Const SRCPAINT = &HEE0086
Public Const BLACKNESS = &H42
Public Const WHITENESS = &HFF0062
Type BITMAP '14 bytes
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Declare Function CreateBitmapIndirect Lib "gdi32" (lpBitmap As BITMAP) As Long
' Text functions:
Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Public Const DT_BOTTOM = &H8
Public Const DT_CENTER = &H1
Public Const DT_LEFT = &H0
Public Const DT_CALCRECT = &H400
Public Const DT_WORDBREAK = &H10
Public Const DT_VCENTER = &H4
Public Const DT_TOP = &H0
Public Const DT_TABSTOP = &H80
Public Const DT_SINGLELINE = &H20
Public Const DT_RIGHT = &H2
Public Const DT_NOCLIP = &H100
Public Const DT_INTERNAL = &H1000
Public Const DT_EXTERNALLEADING = &H200
Public Const DT_EXPANDTABS = &H40
Public Const DT_CHARSTREAM = 4
Public Const DT_NOPREFIX = &H800
Type DRAWTEXTPARAMS
cbSize As Long
iTabLength As Long
iLeftMargin As Long
iRightMargin As Long
uiLengthDrawn As Long
End Type
Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" (ByVal hdc As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, lpDrawTextParams As DRAWTEXTPARAMS) As Long
Declare Function DrawTextExAsNull Lib "user32" Alias "DrawTextExA" (ByVal hdc As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, ByVal lpDrawTextParams As Long) As Long
Public Const DT_EDITCONTROL = &H2000
Public Const DT_PATH_ELLIPSIS = &H4000
Public Const DT_END_ELLIPSIS = &H8000
Public Const DT_MODIFYSTRING = &H10000
Public Const DT_RTLREADING = &H20000
Public Const DT_WORD_ELLIPSIS = &H40000
Type SIZEAPI
cx As Long
cy As Long
End Type
Public Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZEAPI) As Long
Public Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Public Const ANSI_FIXED_FONT = 11
Public Const ANSI_VAR_FONT = 12
Public Const SYSTEM_FONT = 13
Public Const DEFAULT_GUI_FONT = 17 'win95 only
Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
Public Const BF_LEFT = 1
Public Const BF_TOP = 2
Public Const BF_RIGHT = 4
Public Const BF_BOTTOM = 8
Public Const BF_RECT = BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM
Public Const BF_MIDDLE = 2048
Public Const BDR_SUNKENINNER = 8
Public Const BDR_SUNKENOUTER = 2
Public Const FW_NORMAL = 400
Public Const FW_BOLD = 700
Public Const FF_DONTCARE = 0
Public Const DEFAULT_QUALITY = 0
Public Const DEFAULT_PITCH = 0
Public Const DEFAULT_CHARSET = 1
Declare Function CreateFontIndirect& Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT)
Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Public Const CLR_INVALID = -1
' General windows messages:
Public Const WM_CREATE = &H1
Public Const WM_COMMAND = &H111
Public Const WM_KEYDOWN = &H100
Public Const WM_KEYUP = &H101
Public Const WM_CHAR = &H102
Public Const WM_SETFOCUS = &H7
Public Const WM_KILLFOCUS = &H8
Public Const WM_SETFONT = &H30
Public Const WM_GETTEXT = &HD
Public Const WM_GETTEXTLENGTH = &HE
Public Const WM_SETTEXT = &HC
Public Const WM_LBUTTONUP = &H202
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_MBUTTONDOWN = &H207
Public Const WM_MBUTTONUP = &H208
Public Const WM_MOUSEMOVE = &H200
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_RBUTTONUP = &H205
Public Const WM_RBUTTONDBLCLK = &H206
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_MBUTTONDBLCLK = &H209
Public Const WM_MOUSEACTIVATE = &H21
Public Const WM_SIZE = &H5
Public Const WM_GETFONT = &H31
Public Const WM_PARENTNOTIFY = &H210
' mouse activate responses
Public Const MA_ACTIVATE = 1
Public Const MA_ACTIVATEANDEAT = 2
Public Const MA_NOACTIVATE = 3
Public Const MA_NOACTIVATEANDEAT = 4
' Hit test:
Public Const HTCLIENT = 1
' Owner drawn control messages:
Public Const WM_MEASUREITEM = &H2
Public Const WM_DRAWITEM = &H2B
' Combo box notification messages:
Public Const WM_CTLCOLORLISTBOX = &H134
Public Const CBN_CLOSEUP = 8
Public Const CBN_DBLCLK = 2
Public Const CBN_DROPDOWN = 7
Public Const CBN_EDITCHANGE = 5
Public Const CBN_EDITUPDATE = 6
Public Const CBN_ERRSPACE = (-1)
Public Const CBN_KILLFOCUS = 4
Public Const CBN_SELCHANGE = 1
Public Const CBN_SELENDCANCEL = 10
Public Const CBN_SELENDOK = 9
Public Const CBN_SETFOCUS = 3
' List box notification messages:
Public Const LBN_DBLCLK = 2
Public Const LBN_ERRSPACE = (-2)
Public Const LBN_KILLFOCUS = 5
Public Const LBN_SELCANCEL = 3
Public Const LBN_SELCHANGE = 1
Public Const LBN_SETFOCUS = 4
' Useful constants
' Virtual key code constants:
Public Const VK_SHIFT = &H10&
Public Const VK_CONTROL = &H11&
Public Const VK_MENU = &H12& ' Alt key
' Combo box messages:
Public Const CB_ADDSTRING = &H143
Public Const CB_DELETESTRING = &H144
Public Const CB_DIR = &H145
Public Const CB_ERR = (-1)
Public Const CB_ERRSPACE = (-2)
Public Const CB_FINDSTRING = &H14C
Public Const CB_FINDSTRINGEXACT = &H158
Public Const CB_GETCOUNT = &H146
Public Const CB_GETCURSEL = &H147
Public Const CB_GETDROPPEDCONTROLRECT = &H152
Public Const CB_GETDROPPEDSTATE = &H157
Public Const CB_GETEDITSEL = &H140
Public Const CB_GETEXTENDEDUI = &H156
Public Const CB_GETITEMDATA = &H150
Public Const CB_GETITEMHEIGHT = &H154
Public Const CB_GETLBTEXT = &H148
Public Const CB_GETLBTEXTLEN = &H149
Public Const CB_GETLOCALE = &H15A
Public Const CB_INSERTSTRING = &H14A
Public Const CB_LIMITTEXT = &H141
Public Const CB_MSGMAX = &H15B
Public Const CB_OKAY = 0
Public Const CB_RESETCONTENT = &H14B
Public Const CB_SELECTSTRING = &H14D
Public Const CB_SETCURSEL = &H14E
Public Const CB_SETEDITSEL = &H142
Public Const CB_SETEXTENDEDUI = &H155
Public Const CB_SETITEMDATA = &H151
Public Const CB_SETITEMHEIGHT = &H153
Public Const CB_SETLOCALE = &H159
Public Const CB_SHOWDROPDOWN = &H14F
Public Const CB_GETDROPPEDWIDTH = &H15F
Public Const CB_SETDROPPEDWIDTH = &H160
' List box messages:
Public Const LB_ADDFILE = &H196
Public Const LB_ADDSTRING = &H180
Public Const LB_DELETESTRING = &H182
Public Const LB_CTLCODE = 0&
Public Const LB_DIR = &H18D
Public Const LB_ERR = (-1)
Public Const LB_ERRSPACE = (-2)
Public Const LB_FINDSTRING = &H18F
Public Const LB_FINDSTRINGEXACT = &H1A2
Public Const LB_GETANCHORINDEX = &H19D
Public Const LB_GETCARETINDEX = &H19F
Public Const LB_GETCOUNT = &H18B
Public Const LB_GETCURSEL = &H188
Public Const LB_GETHORIZONTALEXTENT = &H193
Public Const LB_GETITEMDATA = &H199
Public Const LB_GETITEMRECT = &H198
Public Const LB_GETITEMHEIGHT = &H1A1
Public Const LB_GETLOCALE = &H1A6
Public Const LB_GETSEL = &H187
Public Const LB_GETSELCOUNT = &H190
Public Const LB_GETSELITEMS = &H191
Public Const LB_GETTEXT = &H189
Public Const LB_GETTEXTLEN = &H18A
Public Const LB_GETTOPINDEX = &H18E
Public Const LB_INSERTSTRING = &H181
Public Const LB_MSGMAX = &H1A8
Public Const LB_OKAY = 0
Public Const LB_RESETCONTENT = &H184
Public Const LB_SELECTSTRING = &H18C
Public Const LB_SELITEMRANGE = &H19B
Public Const LB_SELITEMRANGEEX = &H183
Public Const LB_SETANCHORINDEX = &H19C
Public Const LB_SETCARETINDEX = &H19E
Public Const LB_SETCOLUMNWIDTH = &H195
Public Const LB_SETCOUNT = &H1A7
Public Const LB_SETCURSEL = &H186
Public Const LB_SETHORIZONTALEXTENT = &H194
Public Const LB_SETITEMDATA = &H19A
Public Const LB_SETITEMHEIGHT = &H1A0
Public Const LB_SETLOCALE = &H1A5
Public Const LB_SETSEL = &H185
Public Const LB_SETTABSTOPS = &H192
Public Const LB_SETTOPINDEX = &H197
' Text box messages:
Public Const EM_SETREADONLY = &HCF
' Owner draw style types:
Public Const ODS_CHECKED = &H8
Public Const ODS_DISABLED = &H4
Public Const ODS_FOCUS = &H10
Public Const ODS_GRAYED = &H2
Public Const ODS_SELECTED = &H1
Public Const ODS_COMBOBOXEDIT = &H1000
' Owner draw action types:
Public Const ODA_DRAWENTIRE = &H1
Public Const ODA_FOCUS = &H4
Public Const ODA_SELECT = &H2
' Win32 SDK recommends the use of EnumFontFamiliesEx rather than the other versions:
Public Const LF_FULLFACESIZE = 64
Type ENUMLOGFONTEX
elfLogFont As LOGFONT
elfFullName(LF_FULLFACESIZE) As Byte
elfStyle(LF_FACESIZE) As Byte
elfScript(LF_FACESIZE) As Byte
End Type
Type NEWTEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
' Additional to TEXTMETRIC
ntmFlags As Long
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth As Long
End Type
Type FONTSIGNATURE
fsUsb(4) As Long
fsCsb(2) As Long
End Type
Type TEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
End Type
Type NEWTEXTMETRICEX
ntmTm As NEWTEXTMETRIC
ntmFontSig As FONTSIGNATURE
End Type
' Declares:)
Declare Function EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" (ByVal hdc As Long, lpLogFont As LOGFONT, ByVal lpEnumFontProc As Long, ByVal lParam As Long, ByVal dw As Long) As Long
Private Const ANSI_CHARSET = 0
Private Const SYMBOL_CHARSET = 2
Private Const SHIFTJIS_CHARSET = 128
Private Const HANGEUL_CHARSET = 129
Private Const GB2312_CHARSET = 134
Private Const CHINESEBIG5_CHARSET = 136
Private Const OEM_CHARSET = 255
Private Const JOHAB_CHARSET = 130
Private Const HEBREW_CHARSET = 177
Private Const ARABIC_CHARSET = 178
Private Const GREEK_CHARSET = 161
Private Const TURKISH_CHARSET = 162
Private Const THAI_CHARSET = 222
Private Const EASTEUROPE_CHARSET = 238
Private Const RUSSIAN_CHARSET = 204
Private Const MAC_CHARSET = 77
Private Const BALTIC_CHARSET = 186
Private m_lID As Long
'/* EnumFonts Masks */
Public Const RASTER_FONTTYPE = 1&
Public Const DEVICE_FONTTYPE = 2&
Public Const TRUETYPE_FONTTYPE = 4&
' Object to add items to:
Private m_ctl As ODComboList
Private m_bPrinterFont As Boolean
Public m_EraseBkgndColor As Long
Public Sub gGetHiWordLoWord( _
ByVal lValue As Long, _
ByRef lHiWord As Long, _
ByRef lLoWord As Long _
)
lHiWord = lValue \ &H10000
lLoWord = (lValue And &HFFFF&)
End Sub
Public Function giGetShiftState() As Integer
Dim iR As Integer
Dim lR As Long
Dim lKey As Long
iR = iR Or (-1 * gbKeyIsPressed(VK_SHIFT))
iR = iR Or (-2 * gbKeyIsPressed(VK_MENU))
iR = iR Or (-4 * gbKeyIsPressed(VK_CONTROL))
giGetShiftState = iR
End Function
Public Function gbKeyIsPressed( _
ByVal nVirtKeyCode As KeyCodeConstants _
) As Boolean
Dim lR As Long
lR = GetAsyncKeyState(nVirtKeyCode)
If (lR And &H8000&) = &H8000& Then
gbKeyIsPressed = True
End If
End Function
' Convert Automation color to Windows color
Public Function gTranslateColor(ByVal clr As OLE_COLOR, _
Optional hPal As Long = 0) As Long
If OleTranslateColor(clr, hPal, gTranslateColor) Then
gTranslateColor = CLR_INVALID
End If
End Function
Public Sub gSplitDelimitedString( _
ByVal sString As String, _
ByVal sDelim As String, _
ByRef sValues() As String, _
ByRef iCount As Integer _
)
' ==================================================================
' Splits sString into an array of parts which are
' delimited in the string by sDelim. The array is
' indexed 1-iCount where iCount is the number of
' items. If no items found iCount=1 and the array has
' one element, the original string.
' sString : String to split
' sDelim : Delimiter
' sValues : Return array of values
' iCount : Number of items returned in sValues()
' ==================================================================
Dim iPos As Integer
Dim iNextPos As Integer
Dim iDelimLen As Integer
iCount = 0
Erase sValues
iDelimLen = Len(sDelim)
iPos = 1
iNextPos = InStr(sString, sDelim)
Do While iNextPos > 0
iCount = iCount + 1
ReDim Preserve sValues(1 To iCount) As String
sValues(iCount) = Mid$(sString, iPos, (iNextPos - iPos))
iPos = iNextPos + iDelimLen
iNextPos = InStr(iPos, sString, sDelim)
Loop
iCount = iCount + 1
ReDim Preserve sValues(1 To iCount) As String
sValues(iCount) = Mid$(sString, iPos)
End Sub
Public Function glGetFontDialogUnits( _
ByVal hWnd As Long _
) As Long
Dim hFont As Long
Dim hFontOld As Long
Dim r As Long
Dim avgWidth As Long
Dim hdc As Long
Dim tmp As String
Dim sz As SIZEAPI
'get the hdc to the main window
hdc = GetDC(hWnd)
'with the current font attributes, select the font
hFont& = GetStockObject(ANSI_VAR_FONT)
hFontOld& = SelectObject(hdc, hFont&)
'get it's length, then calculate the average character width
tmp$ = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
r& = GetTextExtentPoint32(hdc, tmp$, 52, sz)
avgWidth& = (sz.cx \ 52)
're-select the previous font & delete the hDc
r& = SelectObject(hdc, hFontOld&)
r& = DeleteObject(hFont&)
r& = ReleaseDC(hWnd, hdc)
'return the average character width
glGetFontDialogUnits& = avgWidth&
End Function
Public Function glCStr(ByVal sThis As String, Optional ByVal lDefault As Long = 0) As Long
On Error Resume Next
glCStr = CLng(sThis)
If (Err.Number <> 0) Then
glCStr = lDefault
End If
End Function
Public Function GetFonts( _
ByVal lHDC As Long, _
ctl As ODComboList, _
ByVal bPrinter As Boolean, _
Optional ByVal sFaceName As String = "" _
) As Long
Dim tLF As LOGFONT
Dim i As Integer
Dim lCharSet As Long
' No re-entrancy, please:
If Not (m_ctl Is Nothing) Then Exit Function
' Get the fonts:
m_bPrinterFont = bPrinter
Set m_ctl = ctl
m_lID = m_lID + 1
If Len(sFaceName) > 0 Then
For i = 1 To Len(sFaceName)
tLF.lfFaceName(i - 1) = Asc(Mid$(sFaceName, i, 1))
Next i
End If
If lCharSet <= 0 Then lCharSet = ANSI_CHARSET
tLF.lfCharSet = lCharSet
GetFonts = EnumFontFamiliesEx(lHDC, tLF, AddressOf EnumFontFamExProc, m_lID, 0)
Set m_ctl = Nothing
End Function
Public Function EnumFontFamExProc(ByVal lpelfe As Long, ByVal lpntme As Long, ByVal iFontType As Long, ByVal lParam As Long) As Long
' The callback function for EnumFontFamiliesEx.
' lpelf points to an ENUMLOGFONTEX structure, lpntm points to either
' a NEWTEXTMETRICEX (if true type) or a TEXTMETRIC (non-true type)
' structure.
Dim tLFEx As ENUMLOGFONTEX
Dim sFace As String
Dim lPos As Long
Dim sItem As String
Dim lIconIndex As Long
CopyMemory tLFEx, ByVal lpelfe, LenB(tLFEx) ' Get the ENUMLOGFONTEX info
sFace = StrConv(tLFEx.elfLogFont.lfFaceName, vbUnicode)
lPos = InStr(sFace, Chr$(0))
If (lPos > 0) Then sFace = Left$(sFace, (lPos - 1))
' Only display printer and true type fonts:
If Not (m_bPrinterFont) Then
'If (iFontType And TRUETYPE_FONTTYPE) <> TRUETYPE_FONTTYPE Then
' EnumFontFamExProc = 1
' Exit Function
'End If
End If
' Only display a given font once:
If (m_ctl.FindItemIndex(sFace, True) < 0) Then
If (m_bPrinterFont) Then
lIconIndex = 1
Else
lIconIndex = 0
End If
m_ctl.AddItemAndData sFace, lIconIndex, 2
End If
EnumFontFamExProc = 1
End Function