Sundy便笺2.2.0.2

马云爱逛京东 · 发表于 2019-11-9 19:18:07

欢迎访问技术宅的结界，请注册或者登录吧。

您需要登录才可以下载或查看，没有账号？立即注册→加入我们

×

（部分源代码来自于他人分享）

ComCtlsBase.bas

Option Explicit
#Const ImplementIDEStopProtection = True
#If False Then
Private OLEDropModeNone, OLEDropModeManual
Private CCAppearanceFlat, CCAppearance3D
Private CCBorderStyleNone, CCBorderStyleSingle, CCBorderStyleThin, CCBorderStyleSunken, CCBorderStyleRaised
Private CCBackStyleTransparent, CCBackStyleOpaque
Private CCLeftRightAlignmentLeft, CCLeftRightAlignmentRight
Private CCVerticalAlignmentTop, CCVerticalAlignmentCenter, CCVerticalAlignmentBottom
Private CCIMEModeNoControl, CCIMEModeOn, CCIMEModeOff, CCIMEModeDisable, CCIMEModeHiragana, CCIMEModeKatakana, CCIMEModeKatakanaHalf, CCIMEModeAlphaFull, CCIMEModeAlpha, CCIMEModeHangulFull, CCIMEModeHangul
Private CCRightToLeftModeNoControl, CCRightToLeftModeVBAME, CCRightToLeftModeSystemLocale, CCRightToLeftModeUserLocale, CCRightToLeftModeOSLanguage
#End If
Public Enum OLEDropModeConstants
OLEDropModeNone = vbOLEDropNone
OLEDropModeManual = vbOLEDropManual
End Enum
Public Enum CCAppearanceConstants
CCAppearanceFlat = 0
CCAppearance3D = 1
End Enum
Public Enum CCBorderStyleConstants
CCBorderStyleNone = 0
CCBorderStyleSingle = 1
CCBorderStyleThin = 2
CCBorderStyleSunken = 3
CCBorderStyleRaised = 4
End Enum
Public Enum CCBackStyleConstants
CCBackStyleTransparent = 0
CCBackStyleOpaque = 1
End Enum
Public Enum CCLeftRightAlignmentConstants
CCLeftRightAlignmentLeft = 0
CCLeftRightAlignmentRight = 1
End Enum
Public Enum CCVerticalAlignmentConstants
CCVerticalAlignmentTop = 0
CCVerticalAlignmentCenter = 1
CCVerticalAlignmentBottom = 2
End Enum
Public Enum CCIMEModeConstants
CCIMEModeNoControl = 0
CCIMEModeOn = 1
CCIMEModeOff = 2
CCIMEModeDisable = 3
CCIMEModeHiragana = 4
CCIMEModeKatakana = 5
CCIMEModeKatakanaHalf = 6
CCIMEModeAlphaFull = 7
CCIMEModeAlpha = 8
CCIMEModeHangulFull = 9
CCIMEModeHangul = 10
End Enum
Public Enum CCRightToLeftModeConstants
CCRightToLeftModeNoControl = 0
CCRightToLeftModeVBAME = 1
CCRightToLeftModeSystemLocale = 2
CCRightToLeftModeUserLocale = 3
CCRightToLeftModeOSLanguage = 4
End Enum
Private Type TINITCOMMONCONTROLSEX
dwSize As Long
dwICC As Long
End Type
Private Type DLLVERSIONINFO
cbSize As Long
dwMajor As Long
dwMinor As Long
dwBuildNumber As Long
dwPlatformID As Long
End Type
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformID As Long
szCSDVersion(0 To ((128 * 2) - 1)) As Byte
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type CWPRETSTRUCT
lResult As Long
lParam As Long
wParam As Long
Message As Long
hwnd As Long
End Type
Private Type TRACKMOUSEEVENTSTRUCT
cbSize As Long
dwFlags As Long
hWndTrack As Long
dwHoverTime As Long
End Type
Private Type TMSG
hwnd As Long
Message As Long
wParam As Long
lParam As Long
Time As Long
PT As POINTAPI
End Type
Private Type CLSID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type TLOCALESIGNATURE
lsUsb(0 To 15) As Byte
lsCsbDefault(0 To 1) As Long
lsCsbSupported(0 To 1) As Long
End Type
Private Type TOOLINFO
cbSize As Long
uFlags As Long
hwnd As Long
uId As Long
RC As RECT
hInst As Long
lpszText As Long
lParam As Long
End Type
Public Declare Function ComCtlsPtrToShadowObj Lib "msvbvm60.dll" Alias "__vbaObjSetAddref" (ByRef Destination As Any, ByVal lpObject As Long) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal hMem As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function InitCommonControlsEx Lib "comctl32" (ByRef ICCEX As TINITCOMMONCONTROLSEX) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageW" (ByRef lpMsg As TMSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExW" (ByVal IDHook As Long, ByVal lpfn As Long, ByVal hMod As Long, ByVal dwThreadID As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetKeyboardLayout Lib "user32" (ByVal dwThreadID As Long) As Long
Private Declare Function CoTaskMemAlloc Lib "ole32" (ByVal cBytes As Long) As Long
Private Declare Function ImmIsIME Lib "imm32" (ByVal hKL As Long) As Long
Private Declare Function ImmCreateContext Lib "imm32" () As Long
Private Declare Function ImmDestroyContext Lib "imm32" (ByVal hIMC As Long) As Long
Private Declare Function ImmGetContext Lib "imm32" (ByVal hwnd As Long) As Long
Private Declare Function ImmReleaseContext Lib "imm32" (ByVal hwnd As Long, ByVal hIMC As Long) As Long
Private Declare Function ImmGetOpenStatus Lib "imm32" (ByVal hIMC As Long) As Long
Private Declare Function ImmSetOpenStatus Lib "imm32" (ByVal hIMC As Long, ByVal fOpen As Long) As Long
Private Declare Function ImmAssociateContext Lib "imm32" (ByVal hwnd As Long, ByVal hIMC As Long) As Long
Private Declare Function ImmGetConversionStatus Lib "imm32" (ByVal hIMC As Long, ByRef lpfdwConversion As Long, ByRef lpfdwSentence As Long) As Long
Private Declare Function ImmSetConversionStatus Lib "imm32" (ByVal hIMC As Long, ByVal lpfdwConversion As Long, ByVal lpfdwSentence As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As Any, ByVal bErase As Long) As Long
Private Declare Function TrackMouseEvent Lib "user32" (ByRef lpEventTrack As TRACKMOUSEEVENTSTRUCT) As Long
Private Declare Function GetSystemDefaultLangID Lib "kernel32" () As Integer
Private Declare Function GetUserDefaultLangID Lib "kernel32" () As Integer
Private Declare Function GetUserDefaultUILanguage Lib "kernel32" () As Integer
Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoW" (ByVal LCID As Long, ByVal LCType As Long, ByVal lpLCData As Long, ByVal cchData As Long) As Long
Private Declare Function IsDialogMessage Lib "user32" Alias "IsDialogMessageW" (ByVal hDlg As Long, ByRef lpMsg As TMSG) As Long
Private Declare Function DllGetVersion Lib "comctl32" (ByRef pdvi As DLLVERSIONINFO) As Long
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExW" (ByRef lpVersionInfo As OSVERSIONINFO) As Long
Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryW" (ByVal lpLibFileName As Long) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private 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
Private Declare Function SetProp Lib "user32" Alias "SetPropW" (ByVal hwnd As Long, ByVal lpString As Long, ByVal hData As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropW" (ByVal hwnd As Long, ByVal lpString As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropW" (ByVal hwnd As Long, ByVal lpString As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function DefSubclassProc Lib "comctl32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowSubclass_W2K Lib "comctl32" Alias "#410" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass_W2K Lib "comctl32" Alias "#412" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function DefSubclassProc_W2K Lib "comctl32" Alias "#413" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const GWL_STYLE As Long = (-16)
Private Const GWL_EXSTYLE As Long = (-20)
Private Const WM_DESTROY As Long = &H2
Private Const WM_NCDESTROY As Long = &H82
Private Const WM_UAHDESTROYWINDOW As Long = &H90
Private Const WM_INITDIALOG As Long = &H110
Private Const WM_USER As Long = &H400
Private Const E_NOTIMPL As Long = &H80004001
Private Const E_NOINTERFACE As Long = &H80004002
Private Const E_POINTER As Long = &H80004003
Private Const S_FALSE As Long = &H1
Private Const S_OK As Long = &H0
Private ShellModHandle As Long, ShellModCount As Long
Private CdlPDEXVTableIPDCB(0 To 5) As Long
Private CdlFRHookHandle As Long
Private CdlFRDialogHandle() As Long, CdlFRDialogCount As Long
#If ImplementIDEStopProtection = True Then
Private Declare Function VirtualAlloc Lib "kernel32" (ByRef lpAddress As Long, ByVal dwSize As Long, ByVal flAllocType As Long, ByVal flProtect As Long) As Long
Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, ByRef lpflOldProtect As Long) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleW" (ByVal lpModuleName As Long) As Long
Private Const MEM_COMMIT As Long = &H1000
Private Const PAGE_EXECUTE_READWRITE As Long = &H40
Private Type IMAGE_DATA_DIRECTORY
VirtualAddress As Long
Size As Long
End Type
Private Type IMAGE_OPTIONAL_HEADER32
Magic As Integer
MajorLinkerVersion As Byte
MinorLinkerVersion As Byte
SizeOfCode As Long
SizeOfInitalizedData As Long
SizeOfUninitalizedData As Long
AddressOfEntryPoint As Long
BaseOfCode As Long
BaseOfData As Long
ImageBase As Long
SectionAlignment As Long
FileAlignment As Long
MajorOperatingSystemVer As Integer
MinorOperatingSystemVer As Integer
MajorImageVersion As Integer
MinorImageVersion As Integer
MajorSubsystemVersion As Integer
MinorSubsystemVersion As Integer
Reserved1 As Long
SizeOfImage As Long
SizeOfHeaders As Long
CheckSum As Long
Subsystem As Integer
DllCharacteristics As Integer
SizeOfStackReserve As Long
SizeOfStackCommit As Long
SizeOfHeapReserve As Long
SizeOfHeapCommit As Long
LoaderFlags As Long
NumberOfRvaAndSizes As Long
DataDirectory(15) As IMAGE_DATA_DIRECTORY
End Type
Private Type IMAGE_DOS_HEADER
e_magic As Integer
e_cblp As Integer
e_cp As Integer
e_crlc As Integer
e_cparhdr As Integer
e_minalloc As Integer
e_maxalloc As Integer
e_ss As Integer
e_sp As Integer
e_csum As Integer
e_ip As Integer
e_cs As Integer
e_lfarlc As Integer
e_onvo As Integer
e_res(0 To 3) As Integer
e_oemid As Integer
e_oeminfo As Integer
e_res2(0 To 9) As Integer
e_lfanew As Long
End Type
#End If
Public Sub ComCtlsLoadShellMod()
If (ShellModHandle Or ShellModCount) = 0 Then ShellModHandle = LoadLibrary(StrPtr("Shell32.dll"))
ShellModCount = ShellModCount + 1
End Sub
Public Sub ComCtlsReleaseShellMod()
ShellModCount = ShellModCount - 1
If ShellModCount = 0 And ShellModHandle <> 0 Then
FreeLibrary ShellModHandle
ShellModHandle = 0
End If
End Sub
Public Sub ComCtlsInitCC(ByVal ICC As Long)
Dim ICCEX As TINITCOMMONCONTROLSEX
With ICCEX
.dwSize = LenB(ICCEX)
.dwICC = ICC
End With
InitCommonControlsEx ICCEX
End Sub
Public Sub ComCtlsShowAllUIStates(ByVal hwnd As Long)
Const WM_UPDATEUISTATE As Long = &H128
Const UIS_CLEAR As Long = 2, UISF_HIDEFOCUS As Long = &H1, UISF_HIDEACCEL As Long = &H2
SendMessage hwnd, WM_UPDATEUISTATE, MakeDWord(UIS_CLEAR, UISF_HIDEFOCUS Or UISF_HIDEACCEL), ByVal 0&
End Sub
Public Sub ComCtlsInitBorderStyle(ByRef dwStyle As Long, ByRef dwExStyle As Long, ByVal Value As CCBorderStyleConstants)
Const WS_BORDER As Long = &H800000, WS_DLGFRAME As Long = &H400000
Const WS_EX_CLIENTEDGE As Long = &H200, WS_EX_STATICEDGE As Long = &H20000, WS_EX_WINDOWEDGE As Long = &H100
Select Case Value
Case CCBorderStyleSingle
dwStyle = dwStyle Or WS_BORDER
Case CCBorderStyleThin
dwExStyle = dwExStyle Or WS_EX_STATICEDGE
Case CCBorderStyleSunken
dwExStyle = dwExStyle Or WS_EX_CLIENTEDGE
Case CCBorderStyleRaised
dwExStyle = dwExStyle Or WS_EX_WINDOWEDGE
dwStyle = dwStyle Or WS_DLGFRAME
End Select
End Sub
Public Sub ComCtlsChangeBorderStyle(ByVal hwnd As Long, ByVal Value As CCBorderStyleConstants)
Const WS_BORDER As Long = &H800000, WS_DLGFRAME As Long = &H400000
Const WS_EX_CLIENTEDGE As Long = &H200, WS_EX_STATICEDGE As Long = &H20000, WS_EX_WINDOWEDGE As Long = &H100
Dim dwStyle As Long, dwExStyle As Long
dwStyle = GetWindowLong(hwnd, GWL_STYLE)
dwExStyle = GetWindowLong(hwnd, GWL_EXSTYLE)
If (dwStyle And WS_BORDER) = WS_BORDER Then dwStyle = dwStyle And Not WS_BORDER
If (dwStyle And WS_DLGFRAME) = WS_DLGFRAME Then dwStyle = dwStyle And Not WS_DLGFRAME
If (dwExStyle And WS_EX_STATICEDGE) = WS_EX_STATICEDGE Then dwExStyle = dwExStyle And Not WS_EX_STATICEDGE
If (dwExStyle And WS_EX_CLIENTEDGE) = WS_EX_CLIENTEDGE Then dwExStyle = dwExStyle And Not WS_EX_CLIENTEDGE
If (dwExStyle And WS_EX_WINDOWEDGE) = WS_EX_WINDOWEDGE Then dwExStyle = dwExStyle And Not WS_EX_WINDOWEDGE
Call ComCtlsInitBorderStyle(dwStyle, dwExStyle, Value)
SetWindowLong hwnd, GWL_STYLE, dwStyle
SetWindowLong hwnd, GWL_EXSTYLE, dwExStyle
Call ComCtlsFrameChanged(hwnd)
End Sub
Public Sub ComCtlsFrameChanged(ByVal hwnd As Long)
Const SWP_FRAMECHANGED As Long = &H20, SWP_NOMOVE As Long = &H2, SWP_NOOWNERZORDER As Long = &H200, SWP_NOSIZE As Long = &H1, SWP_NOZORDER As Long = &H4
SetWindowPos hwnd, 0, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOOWNERZORDER Or SWP_NOZORDER Or SWP_FRAMECHANGED
End Sub
Public Sub ComCtlsInitToolTip(ByVal hwnd As Long)
Const WS_EX_TOPMOST As Long = &H8, HWND_TOPMOST As Long = (-1)
Const SWP_NOMOVE As Long = &H2, SWP_NOSIZE As Long = &H1, SWP_NOACTIVATE As Long = &H10
If Not (GetWindowLong(hwnd, GWL_EXSTYLE) And WS_EX_TOPMOST) = WS_EX_TOPMOST Then SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE Or SWP_NOACTIVATE
Const TTM_SETMAXTIPWIDTH As Long = (WM_USER + 24)
SendMessage hwnd, TTM_SETMAXTIPWIDTH, 0, ByVal &H7FFF&
End Sub
Public Sub ComCtlsCreateIMC(ByVal hwnd As Long, ByRef hIMC As Long)
If hIMC = 0 Then
hIMC = ImmCreateContext()
If hIMC <> 0 Then ImmAssociateContext hwnd, hIMC
End If
End Sub
Public Sub ComCtlsDestroyIMC(ByVal hwnd As Long, ByRef hIMC As Long)
If hIMC <> 0 Then
ImmAssociateContext hwnd, 0
ImmDestroyContext hIMC
hIMC = 0
End If
End Sub
Public Sub ComCtlsSetIMEMode(ByVal hwnd As Long, ByVal hIMCOrig As Long, ByVal Value As CCIMEModeConstants)
Const IME_CMODE_ALPHANUMERIC As Long = &H0, IME_CMODE_NATIVE As Long = &H1, IME_CMODE_KATAKANA As Long = &H2, IME_CMODE_FULLSHAPE As Long = &H8
Dim hKL As Long
hKL = GetKeyboardLayout(0)
If ImmIsIME(hKL) = 0 Or hIMCOrig = 0 Then Exit Sub
Dim hIMC As Long
hIMC = ImmGetContext(hwnd)
If Value = CCIMEModeDisable Then
If hIMC <> 0 Then
ImmReleaseContext hwnd, hIMC
ImmAssociateContext hwnd, 0
End If
Else
If hIMC = 0 Then
ImmAssociateContext hwnd, hIMCOrig
hIMC = ImmGetContext(hwnd)
End If
If hIMC <> 0 And Value <> CCIMEModeNoControl Then
Dim dwConversion As Long, dwSentence As Long
ImmGetConversionStatus hIMC, dwConversion, dwSentence
Select Case Value
Case CCIMEModeOn
ImmSetOpenStatus hIMC, 1
Case CCIMEModeOff
ImmSetOpenStatus hIMC, 0
Case CCIMEModeHiragana
ImmSetOpenStatus hIMC, 1
If Not (dwConversion And IME_CMODE_NATIVE) = IME_CMODE_NATIVE Then dwConversion = dwConversion Or IME_CMODE_NATIVE
If Not (dwConversion And IME_CMODE_FULLSHAPE) = IME_CMODE_FULLSHAPE Then dwConversion = dwConversion Or IME_CMODE_FULLSHAPE
If (dwConversion And IME_CMODE_KATAKANA) = IME_CMODE_KATAKANA Then dwConversion = dwConversion And Not IME_CMODE_KATAKANA
Case CCIMEModeKatakana
ImmSetOpenStatus hIMC, 1
If Not (dwConversion And IME_CMODE_NATIVE) = IME_CMODE_NATIVE Then dwConversion = dwConversion Or IME_CMODE_NATIVE
If Not (dwConversion And IME_CMODE_KATAKANA) = IME_CMODE_KATAKANA Then dwConversion = dwConversion Or IME_CMODE_KATAKANA
If Not (dwConversion And IME_CMODE_FULLSHAPE) = IME_CMODE_FULLSHAPE Then dwConversion = dwConversion Or IME_CMODE_FULLSHAPE
Case CCIMEModeKatakanaHalf
ImmSetOpenStatus hIMC, 1
If Not (dwConversion And IME_CMODE_NATIVE) = IME_CMODE_NATIVE Then dwConversion = dwConversion Or IME_CMODE_NATIVE
If Not (dwConversion And IME_CMODE_KATAKANA) = IME_CMODE_KATAKANA Then dwConversion = dwConversion Or IME_CMODE_KATAKANA
If (dwConversion And IME_CMODE_FULLSHAPE) = IME_CMODE_FULLSHAPE Then dwConversion = dwConversion And Not IME_CMODE_FULLSHAPE
Case CCIMEModeAlphaFull
ImmSetOpenStatus hIMC, 1
If Not (dwConversion And IME_CMODE_FULLSHAPE) = IME_CMODE_FULLSHAPE Then dwConversion = dwConversion Or IME_CMODE_FULLSHAPE
If (dwConversion And IME_CMODE_NATIVE) = IME_CMODE_NATIVE Then dwConversion = dwConversion And Not IME_CMODE_NATIVE
If (dwConversion And IME_CMODE_KATAKANA) = IME_CMODE_KATAKANA Then dwConversion = dwConversion And Not IME_CMODE_KATAKANA
Case CCIMEModeAlpha
ImmSetOpenStatus hIMC, 1
If Not (dwConversion And IME_CMODE_ALPHANUMERIC) = IME_CMODE_ALPHANUMERIC Then dwConversion = dwConversion Or IME_CMODE_ALPHANUMERIC
If (dwConversion And IME_CMODE_NATIVE) = IME_CMODE_NATIVE Then dwConversion = dwConversion And Not IME_CMODE_NATIVE
If (dwConversion And IME_CMODE_KATAKANA) = IME_CMODE_KATAKANA Then dwConversion = dwConversion And Not IME_CMODE_KATAKANA
If (dwConversion And IME_CMODE_FULLSHAPE) = IME_CMODE_FULLSHAPE Then dwConversion = dwConversion And Not IME_CMODE_FULLSHAPE
Case CCIMEModeHangulFull
ImmSetOpenStatus hIMC, 1
If Not (dwConversion And IME_CMODE_NATIVE) = IME_CMODE_NATIVE Then dwConversion = dwConversion Or IME_CMODE_NATIVE
If Not (dwConversion And IME_CMODE_FULLSHAPE) = IME_CMODE_FULLSHAPE Then dwConversion = dwConversion Or IME_CMODE_FULLSHAPE
Case CCIMEModeHangul
ImmSetOpenStatus hIMC, 1
If Not (dwConversion And IME_CMODE_NATIVE) = IME_CMODE_NATIVE Then dwConversion = dwConversion Or IME_CMODE_NATIVE
If (dwConversion And IME_CMODE_FULLSHAPE) = IME_CMODE_FULLSHAPE Then dwConversion = dwConversion And Not IME_CMODE_FULLSHAPE
End Select
ImmSetConversionStatus hIMC, dwConversion, dwSentence
ImmReleaseContext hwnd, hIMC
End If
End If
End Sub
Public Sub ComCtlsRequestMouseLeave(ByVal hwnd As Long)
Const TME_LEAVE As Long = &H2
Dim TME As TRACKMOUSEEVENTSTRUCT
With TME
.cbSize = LenB(TME)
.hWndTrack = hwnd
.dwFlags = TME_LEAVE
End With
TrackMouseEvent TME
End Sub
Public Sub ComCtlsCheckRightToLeft(ByRef Value As Boolean, ByVal UserControlValue As Boolean, ByVal ModeValue As CCRightToLeftModeConstants)
If Value = False Then Exit Sub
Select Case ModeValue
Case CCRightToLeftModeNoControl
Case CCRightToLeftModeVBAME
Value = UserControlValue
Case CCRightToLeftModeSystemLocale, CCRightToLeftModeUserLocale, CCRightToLeftModeOSLanguage
Const LOCALE_FONTSIGNATURE As Long = &H58, SORT_DEFAULT As Long = &H0
Dim LangID As Integer, LCID As Long, LocaleSig As TLOCALESIGNATURE
Select Case ModeValue
Case CCRightToLeftModeSystemLocale
LangID = GetSystemDefaultLangID()
Case CCRightToLeftModeUserLocale
LangID = GetUserDefaultLangID()
Case CCRightToLeftModeOSLanguage
LangID = GetUserDefaultUILanguage()
End Select
LCID = (SORT_DEFAULT * &H10000) Or LangID
If GetLocaleInfo(LCID, LOCALE_FONTSIGNATURE, VarPtr(LocaleSig), (LenB(LocaleSig) / 2)) <> 0 Then
' Unicode subset bitfield 0 to 127. Bit 123 = Layout progress, horizontal from right to left
Value = CBool((LocaleSig.lsUsb(15) And (2 ^ (4 - 1))) <> 0)
End If
End Select
End Sub
Public Sub ComCtlsSetRightToLeft(ByVal hwnd As Long, ByVal dwMask As Long)
Const WS_EX_LAYOUTRTL As Long = &H400000, WS_EX_RTLREADING As Long = &H2000, WS_EX_RIGHT As Long = &H1000, WS_EX_LEFTSCROLLBAR As Long = &H4000
' WS_EX_LAYOUTRTL will take care of both layout and reading order with the single flag and mirrors the window.
Dim dwExStyle As Long
dwExStyle = GetWindowLong(hwnd, GWL_EXSTYLE)
If (dwExStyle And WS_EX_LAYOUTRTL) = WS_EX_LAYOUTRTL Then dwExStyle = dwExStyle And Not WS_EX_LAYOUTRTL
If (dwExStyle And WS_EX_RTLREADING) = WS_EX_RTLREADING Then dwExStyle = dwExStyle And Not WS_EX_RTLREADING
If (dwExStyle And WS_EX_RIGHT) = WS_EX_RIGHT Then dwExStyle = dwExStyle And Not WS_EX_RIGHT
If (dwExStyle And WS_EX_LEFTSCROLLBAR) = WS_EX_LEFTSCROLLBAR Then dwExStyle = dwExStyle And Not WS_EX_LEFTSCROLLBAR
If (dwMask And WS_EX_LAYOUTRTL) = WS_EX_LAYOUTRTL Then dwExStyle = dwExStyle Or WS_EX_LAYOUTRTL
If (dwMask And WS_EX_RTLREADING) = WS_EX_RTLREADING Then dwExStyle = dwExStyle Or WS_EX_RTLREADING
If (dwMask And WS_EX_RIGHT) = WS_EX_RIGHT Then dwExStyle = dwExStyle Or WS_EX_RIGHT
If (dwMask And WS_EX_LEFTSCROLLBAR) = WS_EX_LEFTSCROLLBAR Then dwExStyle = dwExStyle Or WS_EX_LEFTSCROLLBAR
Const WS_POPUP As Long = &H80000000
If (GetWindowLong(hwnd, GWL_STYLE) And WS_POPUP) = 0 Then
SetWindowLong hwnd, GWL_EXSTYLE, dwExStyle
InvalidateRect hwnd, ByVal 0&, 1
Call ComCtlsFrameChanged(hwnd)
Else
' ToolTip control supports only the WS_EX_LAYOUTRTL flag.
' Set TTF_RTLREADING flag when dwMask contains WS_EX_RTLREADING, though WS_EX_RTLREADING will not be actually set.
If (dwExStyle And WS_EX_RTLREADING) = WS_EX_RTLREADING Then dwExStyle = dwExStyle And Not WS_EX_RTLREADING
If (dwExStyle And WS_EX_RIGHT) = WS_EX_RIGHT Then dwExStyle = dwExStyle And Not WS_EX_RIGHT
If (dwExStyle And WS_EX_LEFTSCROLLBAR) = WS_EX_LEFTSCROLLBAR Then dwExStyle = dwExStyle And Not WS_EX_LEFTSCROLLBAR
SetWindowLong hwnd, GWL_EXSTYLE, dwExStyle
Const TTM_SETTOOLINFOA As Long = (WM_USER + 9)
Const TTM_SETTOOLINFOW As Long = (WM_USER + 54)
Const TTM_SETTOOLINFO As Long = TTM_SETTOOLINFOW
Const TTM_GETTOOLCOUNT As Long = (WM_USER + 13)
Const TTM_ENUMTOOLSA As Long = (WM_USER + 14)
Const TTM_ENUMTOOLSW As Long = (WM_USER + 58)
Const TTM_ENUMTOOLS As Long = TTM_ENUMTOOLSW
Const TTM_UPDATE As Long = (WM_USER + 29)
Const TTF_RTLREADING As Long = &H4
Dim i As Long, TI As TOOLINFO, Buffer As String
With TI
.cbSize = LenB(TI)
Buffer = String(80, vbNullChar)
.lpszText = StrPtr(Buffer)
For i = 1 To SendMessage(hwnd, TTM_GETTOOLCOUNT, 0, ByVal 0&)
If SendMessage(hwnd, TTM_ENUMTOOLS, i - 1, ByVal VarPtr(TI)) <> 0 Then
If (dwMask And WS_EX_LAYOUTRTL) = WS_EX_LAYOUTRTL Or (dwMask And WS_EX_RTLREADING) = 0 Then
If (.uFlags And TTF_RTLREADING) = TTF_RTLREADING Then .uFlags = .uFlags And Not TTF_RTLREADING
Else
If (.uFlags And TTF_RTLREADING) = 0 Then .uFlags = .uFlags Or TTF_RTLREADING
End If
SendMessage hwnd, TTM_SETTOOLINFO, 0, ByVal VarPtr(TI)
SendMessage hwnd, TTM_UPDATE, 0, ByVal 0&
End If
Next i
End With
End If
End Sub
Public Sub ComCtlsIPPBSetDisplayStringMousePointer(ByVal MousePointer As Integer, ByRef DisplayName As String)
Select Case MousePointer
Case 0: DisplayName = "0 - Default"
Case 1: DisplayName = "1 - Arrow"
Case 2: DisplayName = "2 - Cross"
Case 3: DisplayName = "3 - I-Beam"
Case 4: DisplayName = "4 - Hand"
Case 5: DisplayName = "5 - Size"
Case 6: DisplayName = "6 - Size NE SW"
Case 7: DisplayName = "7 - Size N S"
Case 8: DisplayName = "8 - Size NW SE"
Case 9: DisplayName = "9 - Size W E"
Case 10: DisplayName = "10 - Up Arrow"
Case 11: DisplayName = "11 - Hourglass"
Case 12: DisplayName = "12 - No Drop"
Case 13: DisplayName = "13 - Arrow and Hourglass"
Case 14: DisplayName = "14 - Arrow and Question"
Case 15: DisplayName = "15 - Size All"
Case 16: DisplayName = "16 - Arrow and CD"
Case 99: DisplayName = "99 - Custom"
End Select
End Sub
Public Sub ComCtlsIPPBSetPredefinedStringsMousePointer(ByRef StringsOut() As String, ByRef CookiesOut() As Long)
ReDim StringsOut(0 To (17 + 1)) As String
ReDim CookiesOut(0 To (17 + 1)) As Long
StringsOut(0) = "0 - Default": CookiesOut(0) = 0
StringsOut(1) = "1 - Arrow": CookiesOut(1) = 1
StringsOut(2) = "2 - Cross": CookiesOut(2) = 2
StringsOut(3) = "3 - I-Beam": CookiesOut(3) = 3
StringsOut(4) = "4 - Hand": CookiesOut(4) = 4
StringsOut(5) = "5 - Size": CookiesOut(5) = 5
StringsOut(6) = "6 - Size NE SW": CookiesOut(6) = 6
StringsOut(7) = "7 - Size N S": CookiesOut(7) = 7
StringsOut(8) = "8 - Size NW SE": CookiesOut(8) = 8
StringsOut(9) = "9 - Size W E": CookiesOut(9) = 9
StringsOut(10) = "10 - Up Arrow": CookiesOut(10) = 10
StringsOut(11) = "11 - Hourglass": CookiesOut(11) = 11
StringsOut(12) = "12 - No Drop": CookiesOut(12) = 12
StringsOut(13) = "13 - Arrow and Hourglass": CookiesOut(13) = 13
StringsOut(14) = "14 - Arrow and Question": CookiesOut(14) = 14
StringsOut(15) = "15 - Size All": CookiesOut(15) = 15
StringsOut(16) = "16 - Arrow and CD": CookiesOut(16) = 16
StringsOut(17) = "99 - Custom": CookiesOut(17) = 99
End Sub
Public Sub ComCtlsIPPBSetPredefinedStringsImageList(ByRef StringsOut() As String, ByRef CookiesOut() As Long, ByRef ControlsEnum As VBRUN.ParentControls, ByRef ImageListArray() As String)
Dim ControlEnum As Object, PropUBound As Long
PropUBound = UBound(StringsOut())
ReDim Preserve StringsOut(PropUBound + 1) As String
ReDim Preserve CookiesOut(PropUBound + 1) As Long
StringsOut(PropUBound) = "(None)"
CookiesOut(PropUBound) = PropUBound
For Each ControlEnum In ControlsEnum
If TypeName(ControlEnum) = "ImageList" Then
PropUBound = UBound(StringsOut())
ReDim Preserve StringsOut(PropUBound + 1) As String
ReDim Preserve CookiesOut(PropUBound + 1) As Long
StringsOut(PropUBound) = ProperControlName(ControlEnum)
CookiesOut(PropUBound) = PropUBound
End If
Next ControlEnum
PropUBound = UBound(StringsOut())
ReDim ImageListArray(0 To PropUBound) As String
Dim i As Long
For i = 0 To PropUBound
ImageListArray(i) = StringsOut(i)
Next i
End Sub
Public Sub ComCtlsPPInitComboMousePointer(ByVal ComboBox As Object)
With ComboBox
.AddItem "0 - Default"
.ItemData(.NewIndex) = 0
.AddItem "1 - Arrow"
.ItemData(.NewIndex) = 1
.AddItem "2 - Cross"
.ItemData(.NewIndex) = 2
.AddItem "3 - I-Beam"
.ItemData(.NewIndex) = 3
.AddItem "4 - Hand"
.ItemData(.NewIndex) = 4
.AddItem "5 - Size"
.ItemData(.NewIndex) = 5
.AddItem "6 - Size NE SW"
.ItemData(.NewIndex) = 6
.AddItem "7 - Size N S"
.ItemData(.NewIndex) = 7
.AddItem "8 - Size NW SE"
.ItemData(.NewIndex) = 8
.AddItem "9 - Size W E"
.ItemData(.NewIndex) = 9
.AddItem "10 - Up Arrow"
.ItemData(.NewIndex) = 10
.AddItem "11 - Hourglass"
.ItemData(.NewIndex) = 11
.AddItem "12 - No Drop"
.ItemData(.NewIndex) = 12
.AddItem "13 - Arrow and Hourglass"
.ItemData(.NewIndex) = 13
.AddItem "14 - Arrow and Question"
.ItemData(.NewIndex) = 14
.AddItem "15 - Size All"
.ItemData(.NewIndex) = 15
.AddItem "16 - Arrow and CD"
.ItemData(.NewIndex) = 16
.AddItem "99 - Custom"
.ItemData(.NewIndex) = 99
End With
End Sub
Public Sub ComCtlsPPInitComboIMEMode(ByVal ComboBox As Object)
With ComboBox
.AddItem CCIMEModeNoControl & " - NoControl"
.ItemData(.NewIndex) = CCIMEModeNoControl
.AddItem CCIMEModeOn & " - On"
.ItemData(.NewIndex) = CCIMEModeOn
.AddItem CCIMEModeOff & " - Off"
.ItemData(.NewIndex) = CCIMEModeOff
.AddItem CCIMEModeDisable & " - Disable"
.ItemData(.NewIndex) = CCIMEModeDisable
.AddItem CCIMEModeHiragana & " - Hiragana"
.ItemData(.NewIndex) = CCIMEModeHiragana
.AddItem CCIMEModeKatakana & " - Katakana"
.ItemData(.NewIndex) = CCIMEModeKatakana
.AddItem CCIMEModeKatakanaHalf & " - KatakanaHalf"
.ItemData(.NewIndex) = CCIMEModeKatakanaHalf
.AddItem CCIMEModeAlphaFull & " - AlphaFull"
.ItemData(.NewIndex) = CCIMEModeAlphaFull
.AddItem CCIMEModeAlpha & " - Alpha"
.ItemData(.NewIndex) = CCIMEModeAlpha
.AddItem CCIMEModeHangulFull & " - HangulFull"
.ItemData(.NewIndex) = CCIMEModeHangulFull
.AddItem CCIMEModeHangul & " - Hangul"
.ItemData(.NewIndex) = CCIMEModeHangul
End With
End Sub
Public Sub ComCtlsPPKeyPressOnlyNumeric(ByRef KeyAscii As Integer)
If KeyAscii < 48 Or KeyAscii > 57 Then If KeyAscii <> 8 Then KeyAscii = 0
End Sub
Public Function ComCtlsPeekCharCode(ByVal hwnd As Long) As Long
Dim Msg As TMSG
Const PM_NOREMOVE As Long = &H0, WM_CHAR As Long = &H102
If PeekMessage(Msg, hwnd, WM_CHAR, WM_CHAR, PM_NOREMOVE) <> 0 Then ComCtlsPeekCharCode = Msg.wParam
End Function
Public Function ComCtlsSupportLevel() As Byte
Static Done As Boolean, Value As Byte
If Done = False Then
Dim Version As DLLVERSIONINFO
On Error Resume Next
Version.cbSize = LenB(Version)
If DllGetVersion(Version) = S_OK Then
If Version.dwMajor = 6 And Version.dwMinor = 0 Then
Value = 1
ElseIf Version.dwMajor > 6 Or (Version.dwMajor = 6 And Version.dwMinor > 0) Then
Value = 2
End If
End If
Done = True
End If
ComCtlsSupportLevel = Value
End Function
Public Function ComCtlsW2KCompatibility() As Boolean
Static Done As Boolean, Value As Boolean
If Done = False Then
Dim Version As OSVERSIONINFO
On Error Resume Next
Version.dwOSVersionInfoSize = LenB(Version)
If GetVersionEx(Version) <> 0 Then
With Version
Const VER_PLATFORM_WIN32_NT As Long = 2
If .dwPlatformID = VER_PLATFORM_WIN32_NT Then
If .dwMajorVersion = 5 And .dwMinorVersion = 0 Then Value = True
End If
End With
End If
Done = True
End If
ComCtlsW2KCompatibility = Value
End Function
Public Sub ComCtlsTopParentValidateControls(ByVal UserControl As Object)
With GetTopUserControl(UserControl)
If TypeOf .Parent Is VB.MDIForm Then
Dim MDIForm As VB.MDIForm
Set MDIForm = .Parent
MDIForm.ValidateControls
ElseIf TypeOf .Parent Is VB.Form Then
Dim Form As VB.Form
Set Form = .Parent
Form.ValidateControls
Else
Const IID_IPropertyPage As String = "{B196B28D-BAB4-101A-B69C-00AA00341D07}"
If VTableInterfaceSupported(.Parent, IID_IPropertyPage) = True Then
Dim PropertyPage As VB.PropertyPage, TempPropertyPage As VB.PropertyPage
CopyMemory TempPropertyPage, ObjPtr(.Parent), 4
Set PropertyPage = TempPropertyPage
CopyMemory TempPropertyPage, 0&, 4
PropertyPage.ValidateControls
End If
End If
End With
End Sub
Public Sub ComCtlsSetSubclass(ByVal hwnd As Long, ByVal This As ISubclass, ByVal dwRefData As Long, Optional ByVal Name As String)
If hwnd = 0 Then Exit Sub
If Name = vbNullString Then Name = "ComCtl"
If GetProp(hwnd, StrPtr(Name & "SubclassInit")) = 0 Then
If ComCtlsW2KCompatibility() = False Then
SetWindowSubclass hwnd, AddressOf ComCtlsSubclassProc, ObjPtr(This), dwRefData
Else
SetWindowSubclass_W2K hwnd, AddressOf ComCtlsSubclassProc, ObjPtr(This), dwRefData
End If
SetProp hwnd, StrPtr(Name & "SubclassID"), ObjPtr(This)
SetProp hwnd, StrPtr(Name & "SubclassInit"), 1
End If
End Sub
Public Function ComCtlsDefaultProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If ComCtlsW2KCompatibility() = False Then
ComCtlsDefaultProc = DefSubclassProc(hwnd, wMsg, wParam, lParam)
Else
ComCtlsDefaultProc = DefSubclassProc_W2K(hwnd, wMsg, wParam, lParam)
End If
End Function
Public Sub ComCtlsRemoveSubclass(ByVal hwnd As Long, Optional ByVal Name As String)
If hwnd = 0 Then Exit Sub
If Name = vbNullString Then Name = "ComCtl"
If GetProp(hwnd, StrPtr(Name & "SubclassInit")) = 1 Then
If ComCtlsW2KCompatibility() = False Then
RemoveWindowSubclass hwnd, AddressOf ComCtlsSubclassProc, GetProp(hwnd, StrPtr(Name & "SubclassID"))
Else
RemoveWindowSubclass_W2K hwnd, AddressOf ComCtlsSubclassProc, GetProp(hwnd, StrPtr(Name & "SubclassID"))
End If
RemoveProp hwnd, StrPtr(Name & "SubclassID")
RemoveProp hwnd, StrPtr(Name & "SubclassInit")
End If
End Sub
Public Function ComCtlsSubclassProc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Select Case wMsg
Case WM_DESTROY
ComCtlsSubclassProc = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
Exit Function
Case WM_NCDESTROY, WM_UAHDESTROYWINDOW
ComCtlsSubclassProc = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
If ComCtlsW2KCompatibility() = False Then
RemoveWindowSubclass hwnd, AddressOf ComCtlsBase.ComCtlsSubclassProc, uIdSubclass
Else
RemoveWindowSubclass_W2K hwnd, AddressOf ComCtlsBase.ComCtlsSubclassProc, uIdSubclass
End If
Exit Function
End Select
On Error Resume Next
Dim This As ISubclass
Set This = PtrToObj(uIdSubclass)
If ERR.Number = 0 Then
ComCtlsSubclassProc = This.Message(hwnd, wMsg, wParam, lParam, dwRefData)
Else
ComCtlsSubclassProc = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
End If
End Function
Public Sub ComCtlsImlListImageIndex(ByVal Control As Object, ByVal ImageList As Variant, ByVal KeyOrIndex As Variant, ByRef ImageIndex As Long)
Dim LngValue As Long
Select Case VarType(KeyOrIndex)
Case vbLong, vbInteger, vbByte
LngValue = KeyOrIndex
Case vbString
Dim ImageListControl As Object
If IsObject(ImageList) Then
Set ImageListControl = ImageList
ElseIf VarType(ImageList) = vbString Then
Dim ControlEnum As Object, CompareName As String
For Each ControlEnum In Control.ControlsEnum
If TypeName(ControlEnum) = "ImageList" Then
CompareName = ProperControlName(ControlEnum)
If CompareName = ImageList And Not CompareName = vbNullString Then
Set ImageListControl = ControlEnum
Exit For
End If
End If
Next ControlEnum
End If
If Not ImageListControl Is Nothing Then
On Error Resume Next
LngValue = ImageListControl.ListImages(KeyOrIndex).Index
On Error GoTo 0
End If
If LngValue = 0 Then ERR.Raise Number:=35601, Description:="Element not found"
Case vbDouble, vbSingle
LngValue = CLng(KeyOrIndex)
Case vbEmpty
Case Else
ERR.Raise 13
End Select
If LngValue < 0 Then ERR.Raise Number:=35600, Description:="Index out of bounds"
ImageIndex = LngValue
End Sub
Public Function ComCtlsLvwSortingFunctionBinary(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal This As ISubclass) As Long
ComCtlsLvwSortingFunctionBinary = This.Message(0, 0, lParam1, lParam2, 10)
End Function
Public Function ComCtlsLvwSortingFunctionText(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal This As ISubclass) As Long
ComCtlsLvwSortingFunctionText = This.Message(0, 0, lParam1, lParam2, 11)
End Function
Public Function ComCtlsLvwSortingFunctionNumeric(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal This As ISubclass) As Long
ComCtlsLvwSortingFunctionNumeric = This.Message(0, 0, lParam1, lParam2, 12)
End Function
Public Function ComCtlsLvwSortingFunctionCurrency(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal This As ISubclass) As Long
ComCtlsLvwSortingFunctionCurrency = This.Message(0, 0, lParam1, lParam2, 13)
End Function
Public Function ComCtlsLvwSortingFunctionDate(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal This As ISubclass) As Long
ComCtlsLvwSortingFunctionDate = This.Message(0, 0, lParam1, lParam2, 14)
End Function
Public Function ComCtlsLvwSortingFunctionGroups(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal This As ISubclass) As Long
ComCtlsLvwSortingFunctionGroups = This.Message(0, 0, lParam1, lParam2, 0)
End Function
Public Function ComCtlsTvwSortingFunctionBinary(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal This As ISubclass) As Long
ComCtlsTvwSortingFunctionBinary = This.Message(0, 0, lParam1, lParam2, 10)
End Function
Public Function ComCtlsTvwSortingFunctionText(ByVal lParam1 As Long, ByVal lParam2 As Long, ByVal This As ISubclass) As Long
ComCtlsTvwSortingFunctionText = This.Message(0, 0, lParam1, lParam2, 11)
End Function
Public Function ComCtlsFtcEnumFontFunction(ByVal lpELF As Long, ByVal lpTM As Long, ByVal FontType As Long, ByVal This As ISubclass) As Long
ComCtlsFtcEnumFontFunction = This.Message(0, lpELF, lpTM, FontType, 10)
End Function
Public Function ComCtlsCdlOFN1CallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lCustData As Long
If wMsg <> WM_INITDIALOG Then
lCustData = GetProp(hDlg, StrPtr("ComCtlsCdlOFN1CallbackProcCustData"))
Else
CopyMemory lCustData, ByVal UnsignedAdd(lParam, 64), 4
SetProp hDlg, StrPtr("ComCtlsCdlOFN1CallbackProcCustData"), lCustData
End If
If lCustData <> 0 Then
Dim This As ISubclass
Set This = PtrToObj(lCustData)
ComCtlsCdlOFN1CallbackProc = This.Message(hDlg, wMsg, wParam, lParam, -1)
Else
ComCtlsCdlOFN1CallbackProc = 0
End If
End Function
Public Function ComCtlsCdlOFN1CallbackProcOldStyle(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lCustData As Long
If wMsg <> WM_INITDIALOG Then
lCustData = GetProp(hDlg, StrPtr("ComCtlsCdlOFN1CallbackProcOldStyleCustData"))
Else
CopyMemory lCustData, ByVal UnsignedAdd(lParam, 64), 4
SetProp hDlg, StrPtr("ComCtlsCdlOFN1CallbackProcOldStyleCustData"), lCustData
End If
If lCustData <> 0 Then
Dim This As ISubclass
Set This = PtrToObj(lCustData)
ComCtlsCdlOFN1CallbackProcOldStyle = This.Message(hDlg, wMsg, wParam, lParam, -1001)
Else
ComCtlsCdlOFN1CallbackProcOldStyle = 0
End If
End Function
Public Function ComCtlsCdlOFN2CallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lCustData As Long
If wMsg <> WM_INITDIALOG Then
lCustData = GetProp(hDlg, StrPtr("ComCtlsCdlOFN2CallbackProcCustData"))
Else
CopyMemory lCustData, ByVal UnsignedAdd(lParam, 64), 4
SetProp hDlg, StrPtr("ComCtlsCdlOFN2CallbackProcCustData"), lCustData
End If
If lCustData <> 0 Then
Dim This As ISubclass
Set This = PtrToObj(lCustData)
ComCtlsCdlOFN2CallbackProc = This.Message(hDlg, wMsg, wParam, lParam, -2)
Else
ComCtlsCdlOFN2CallbackProc = 0
End If
End Function
Public Function ComCtlsCdlOFN2CallbackProcOldStyle(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lCustData As Long
If wMsg <> WM_INITDIALOG Then
lCustData = GetProp(hDlg, StrPtr("ComCtlsCdlOFN2CallbackProcOldStyleCustData"))
Else
CopyMemory lCustData, ByVal UnsignedAdd(lParam, 64), 4
SetProp hDlg, StrPtr("ComCtlsCdlOFN2CallbackProcOldStyleCustData"), lCustData
End If
If lCustData <> 0 Then
Dim This As ISubclass
Set This = PtrToObj(lCustData)
ComCtlsCdlOFN2CallbackProcOldStyle = This.Message(hDlg, wMsg, wParam, lParam, -1002)
Else
ComCtlsCdlOFN2CallbackProcOldStyle = 0
End If
End Function
Public Function ComCtlsCdlCCCallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lCustData As Long
If wMsg <> WM_INITDIALOG Then
lCustData = GetProp(hDlg, StrPtr("ComCtlsCdlCCCallbackProcCustData"))
Else
CopyMemory lCustData, ByVal UnsignedAdd(lParam, 24), 4
SetProp hDlg, StrPtr("ComCtlsCdlCCCallbackProcCustData"), lCustData
End If
If lCustData <> 0 Then
Dim This As ISubclass
Set This = PtrToObj(lCustData)
ComCtlsCdlCCCallbackProc = This.Message(hDlg, wMsg, wParam, lParam, -3)
Else
ComCtlsCdlCCCallbackProc = 0
End If
End Function
Public Function ComCtlsCdlCFCallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lCustData As Long
If wMsg <> WM_INITDIALOG Then
lCustData = GetProp(hDlg, StrPtr("ComCtlsCdlCFCallbackProcCustData"))
Else
CopyMemory lCustData, ByVal UnsignedAdd(lParam, 28), 4
SetProp hDlg, StrPtr("ComCtlsCdlCFCallbackProcCustData"), lCustData
End If
If lCustData <> 0 Then
Dim This As ISubclass
Set This = PtrToObj(lCustData)
ComCtlsCdlCFCallbackProc = This.Message(hDlg, wMsg, wParam, lParam, -4)
Else
ComCtlsCdlCFCallbackProc = 0
End If
End Function
Public Function ComCtlsCdlPDCallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If wMsg <> WM_INITDIALOG Then
ComCtlsCdlPDCallbackProc = 0
Else
Dim lCustData As Long
CopyMemory lCustData, ByVal UnsignedAdd(lParam, 38), 4
If lCustData <> 0 Then
Dim This As ISubclass
Set This = PtrToObj(lCustData)
ComCtlsCdlPDCallbackProc = This.Message(hDlg, wMsg, wParam, lParam, -5)
Else
ComCtlsCdlPDCallbackProc = 0
End If
End If
End Function
Public Function ComCtlsCdlPDEXCallbackPtr(ByVal This As ISubclass) As Long
Dim VTableData(0 To 2) As Long
VTableData(0) = GetVTableIPDCB()
VTableData(1) = 0 ' RefCount is uninstantiated
VTableData(2) = ObjPtr(This)
Dim hMem As Long
hMem = CoTaskMemAlloc(12)
If hMem <> 0 Then
CopyMemory ByVal hMem, VTableData(0), 12
ComCtlsCdlPDEXCallbackPtr = hMem
End If
End Function
Private Function GetVTableIPDCB() As Long
If CdlPDEXVTableIPDCB(0) = 0 Then
CdlPDEXVTableIPDCB(0) = ProcPtr(AddressOf IPDCB_QueryInterface)
CdlPDEXVTableIPDCB(1) = ProcPtr(AddressOf IPDCB_AddRef)
CdlPDEXVTableIPDCB(2) = ProcPtr(AddressOf IPDCB_Release)
CdlPDEXVTableIPDCB(3) = ProcPtr(AddressOf IPDCB_InitDone)
CdlPDEXVTableIPDCB(4) = ProcPtr(AddressOf IPDCB_SelectionChange)
CdlPDEXVTableIPDCB(5) = ProcPtr(AddressOf IPDCB_HandleMessage)
End If
GetVTableIPDCB = VarPtr(CdlPDEXVTableIPDCB(0))
End Function
Private Function IPDCB_QueryInterface(ByVal Ptr As Long, ByRef IID As CLSID, ByRef pvObj As Long) As Long
If VarPtr(pvObj) = 0 Then
IPDCB_QueryInterface = E_POINTER
Exit Function
End If
' IID_IPrintDialogCallback = {5852A2C3-6530-11D1-B6A3-0000F8757BF9}
If IID.Data1 = &H5852A2C3 And IID.Data2 = &H6530 And IID.Data3 = &H11D1 Then
If IID.Data4(0) = &HB6 And IID.Data4(1) = &HA3 And IID.Data4(2) = &H0 And IID.Data4(3) = &H0 _
And IID.Data4(4) = &HF8 And IID.Data4(5) = &H75 And IID.Data4(6) = &H7B And IID.Data4(7) = &HF9 Then
pvObj = Ptr
IPDCB_AddRef Ptr
IPDCB_QueryInterface = S_OK
Else
IPDCB_QueryInterface = E_NOINTERFACE
End If
Else
IPDCB_QueryInterface = E_NOINTERFACE
End If
End Function
Private Function IPDCB_AddRef(ByVal Ptr As Long) As Long
CopyMemory IPDCB_AddRef, ByVal UnsignedAdd(Ptr, 4), 4
IPDCB_AddRef = IPDCB_AddRef + 1
CopyMemory ByVal UnsignedAdd(Ptr, 4), IPDCB_AddRef, 4
End Function
Private Function IPDCB_Release(ByVal Ptr As Long) As Long
CopyMemory IPDCB_Release, ByVal UnsignedAdd(Ptr, 4), 4
IPDCB_Release = IPDCB_Release - 1
CopyMemory ByVal UnsignedAdd(Ptr, 4), IPDCB_Release, 4
If IPDCB_Release = 0 Then CoTaskMemFree Ptr
End Function
Private Function IPDCB_InitDone(ByVal Ptr As Long) As Long
IPDCB_InitDone = S_FALSE
End Function
Private Function IPDCB_SelectionChange(ByVal Ptr As Long) As Long
IPDCB_SelectionChange = S_FALSE
End Function
Private Function IPDCB_HandleMessage(ByVal Ptr As Long, ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByRef Result As Long) As Long
If wMsg <> WM_INITDIALOG Then
IPDCB_HandleMessage = 0
Else
Dim lCustData As Long
CopyMemory lCustData, ByVal UnsignedAdd(Ptr, 8), 4
If lCustData <> 0 Then
Dim This As ISubclass
Set This = PtrToObj(lCustData)
IPDCB_HandleMessage = This.Message(hDlg, wMsg, wParam, lParam, -5)
Else
IPDCB_HandleMessage = 0
End If
End If
IPDCB_HandleMessage = S_FALSE
End Function
Public Function ComCtlsCdlPSDCallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If wMsg <> WM_INITDIALOG Then
ComCtlsCdlPSDCallbackProc = 0
Else
Dim lCustData As Long
CopyMemory lCustData, ByVal UnsignedAdd(lParam, 64), 4
If lCustData <> 0 Then
Dim This As ISubclass
Set This = PtrToObj(lCustData)
ComCtlsCdlPSDCallbackProc = This.Message(hDlg, wMsg, wParam, lParam, -7)
Else
ComCtlsCdlPSDCallbackProc = 0
End If
End If
End Function
Public Function ComCtlsCdlBIFCallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal lParam As Long, ByVal This As ISubclass) As Long
ComCtlsCdlBIFCallbackProc = This.Message(hDlg, wMsg, 0, lParam, -8)
End Function
Public Function ComCtlsCdlFR1CallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If wMsg <> WM_INITDIALOG Then
ComCtlsCdlFR1CallbackProc = 0
Else
Dim lCustData As Long
CopyMemory lCustData, ByVal UnsignedAdd(lParam, 28), 4
If lCustData <> 0 Then
Dim This As ISubclass
Set This = PtrToObj(lCustData)
This.Message hDlg, wMsg, wParam, lParam, -9
End If
' Need to return a nonzero value or else the dialog box will not be shown.
ComCtlsCdlFR1CallbackProc = 1
End If
End Function
Public Function ComCtlsCdlFR2CallbackProc(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If wMsg <> WM_INITDIALOG Then
ComCtlsCdlFR2CallbackProc = 0
Else
Dim lCustData As Long
CopyMemory lCustData, ByVal UnsignedAdd(lParam, 28), 4
If lCustData <> 0 Then
Dim This As ISubclass
Set This = PtrToObj(lCustData)
This.Message hDlg, wMsg, wParam, lParam, -10
End If
' Need to return a nonzero value or else the dialog box will not be shown.
ComCtlsCdlFR2CallbackProc = 1
End If
End Function
Public Sub ComCtlsCdlFRAddHook(ByVal hDlg As Long)
If (CdlFRHookHandle Or CdlFRDialogCount) = 0 Then
Const WH_GETMESSAGE As Long = 3
CdlFRHookHandle = SetWindowsHookEx(WH_GETMESSAGE, AddressOf ComCtlsCdlFRHookProc, 0, App.ThreadID)
ReDim CdlFRDialogHandle(0) As Long
CdlFRDialogHandle(0) = hDlg
Else
ReDim Preserve CdlFRDialogHandle(0 To CdlFRDialogCount) As Long
CdlFRDialogHandle(CdlFRDialogCount) = hDlg
End If
CdlFRDialogCount = CdlFRDialogCount + 1
End Sub
Public Sub ComCtlsCdlFRReleaseHook(ByVal hDlg As Long)
CdlFRDialogCount = CdlFRDialogCount - 1
If CdlFRDialogCount = 0 And CdlFRHookHandle <> 0 Then
UnhookWindowsHookEx CdlFRHookHandle
CdlFRHookHandle = 0
Erase CdlFRDialogHandle()
Else
If CdlFRDialogCount > 0 Then
Dim i As Long
For i = 0 To CdlFRDialogCount
If CdlFRDialogHandle(i) = hDlg And i < CdlFRDialogCount Then
CdlFRDialogHandle(i) = CdlFRDialogHandle(i + 1)
End If
Next i
ReDim Preserve CdlFRDialogHandle(0 To CdlFRDialogCount - 1) As Long
End If
End If
End Sub
Private Function ComCtlsCdlFRHookProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const HC_ACTION As Long = 0, PM_REMOVE As Long = &H1
Const WM_KEYFIRST As Long = &H100, WM_KEYLAST As Long = &H108, WM_NULL As Long = &H0
If nCode >= HC_ACTION And wParam = PM_REMOVE Then
Dim Msg As TMSG
CopyMemory Msg, ByVal lParam, LenB(Msg)
If Msg.Message >= WM_KEYFIRST And Msg.Message <= WM_KEYLAST Then
If CdlFRDialogCount > 0 Then
Dim i As Long
For i = 0 To CdlFRDialogCount - 1
If IsDialogMessage(CdlFRDialogHandle(i), Msg) <> 0 Then
Msg.Message = WM_NULL
Msg.wParam = 0
Msg.lParam = 0
CopyMemory ByVal lParam, Msg, LenB(Msg)
Exit For
End If
Next i
End If
End If
End If
ComCtlsCdlFRHookProc = CallNextHookEx(CdlFRHookHandle, nCode, wParam, lParam)
End Function
Public Sub ComCtlsInitIDEStopProtection()
#If ImplementIDEStopProtection = True Then
If InIDE() = True Then
Dim ASMWrapper As Long, RestorePointer As Long, OldAddress As Long
ASMWrapper = VirtualAlloc(ByVal 0, 20, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
OldAddress = GetProcAddress(GetModuleHandle(StrPtr("vba6.dll")), "EbProjectReset")
RestorePointer = HookIATEntry("vb6.exe", "vba6.dll", "EbProjectReset", ASMWrapper)
WriteCall ASMWrapper, AddressOf ComCtlsIDEStopProtectionHandler
WriteByte ASMWrapper, &HC7 ' MOV
WriteByte ASMWrapper, &H5
WriteLong ASMWrapper, RestorePointer ' IAT Entry
WriteLong ASMWrapper, OldAddress ' Address from EbProjectReset
WriteJump ASMWrapper, OldAddress
End If
#End If
End Sub
#If ImplementIDEStopProtection = True Then
Private Sub ComCtlsIDEStopProtectionHandler()
On Error Resume Next
Call RemoveAllVTableSubclass(VTableInterfaceInPlaceActiveObject)
Call RemoveAllVTableSubclass(VTableInterfaceControl)
Call RemoveAllVTableSubclass(VTableInterfacePerPropertyBrowsing)
Dim AppForm As Form, CurrControl As Control
For Each AppForm In Forms
For Each CurrControl In AppForm.Controls
Select Case TypeName(CurrControl)
Case "Animation", "DTPicker", "MonthView", "Slider", "StatusBar", "TabStrip", "ListBoxW", "ListView", "TreeView", "IPAddress", "ToolBar", "UpDown", "SpinBox", "Pager", "OptionButtonW", "CheckBoxW", "CommandButtonW", "TextBoxW", "HotKey", "CoolBar", "LinkLabel", "CommandLink"
Call ComCtlsRemoveSubclass(CurrControl.hwnd)
Call ComCtlsRemoveSubclass(CurrControl.hWndUserControl)
Case "ProgressBar", "FrameW"
Call ComCtlsRemoveSubclass(CurrControl.hwnd)
Case "ComboBoxW", "FontCombo"
Call ComCtlsRemoveSubclass(CurrControl.hwnd)
If CurrControl.hWndEdit <> 0 Then Call ComCtlsRemoveSubclass(CurrControl.hWndEdit)
If CurrControl.hWndList <> 0 Then Call ComCtlsRemoveSubclass(CurrControl.hWndList)
Call ComCtlsRemoveSubclass(CurrControl.hWndUserControl)
Case "ImageCombo"
Call ComCtlsRemoveSubclass(CurrControl.hwnd)
If CurrControl.hWndCombo <> 0 Then Call ComCtlsRemoveSubclass(CurrControl.hWndCombo)
If CurrControl.hWndEdit <> 0 Then Call ComCtlsRemoveSubclass(CurrControl.hWndEdit)
If CurrControl.hWndList <> 0 Then Call ComCtlsRemoveSubclass(CurrControl.hWndList)
Call ComCtlsRemoveSubclass(CurrControl.hWndUserControl)
Case "RichTextBox", "MCIWnd", "SysInfo"
CurrControl.IDEStop ' Hidden
End Select
Next CurrControl
Next AppForm
If CdlFRDialogCount > 0 Then
Dim DialogHandle() As Long
DialogHandle() = CdlFRDialogHandle()
Const WM_CLOSE As Long = &H10
Dim i As Long
For i = 0 To CdlFRDialogCount - 1
SendMessage DialogHandle(i), WM_CLOSE, 0, ByVal 0&
DoEvents
Next i
End If
End Sub
Private Function HookIATEntry(ByVal Module As String, ByVal Lib As String, ByVal Fnc As String, ByVal NewAddr As Long) As Long
Dim hMod As Long, OldLibFncAddr As Long
Dim lpIAT As Long, IATLen As Long, IATPos As Long
Dim DOSHdr As IMAGE_DOS_HEADER
Dim PEHdr As IMAGE_OPTIONAL_HEADER32
hMod = GetModuleHandle(StrPtr(Module))
If hMod = 0 Then Exit Function
OldLibFncAddr = GetProcAddress(GetModuleHandle(StrPtr(Lib)), Fnc)
If OldLibFncAddr = 0 Then Exit Function
CopyMemory DOSHdr, ByVal hMod, LenB(DOSHdr)
CopyMemory PEHdr, ByVal UnsignedAdd(hMod, DOSHdr.e_lfanew), LenB(PEHdr)
Const IMAGE_NT_SIGNATURE As Long = &H4550
If PEHdr.Magic = IMAGE_NT_SIGNATURE Then
lpIAT = UnsignedAdd(PEHdr.DataDirectory(15).VirtualAddress, hMod)
IATLen = PEHdr.DataDirectory(15).Size
IATPos = lpIAT
Do Until CLngToULng(IATPos) >= CLngToULng(UnsignedAdd(lpIAT, IATLen))
If DeRef(IATPos) = OldLibFncAddr Then
VirtualProtect IATPos, 4, PAGE_EXECUTE_READWRITE, 0
CopyMemory ByVal IATPos, NewAddr, 4
HookIATEntry = IATPos
Exit Do
End If
IATPos = UnsignedAdd(IATPos, 4)
Loop
End If
End Function
Private Function DeRef(ByVal Addr As Long) As Long
CopyMemory DeRef, ByVal Addr, 4
End Function
Private Sub WriteJump(ByRef ASM As Long, ByRef Addr As Long)
WriteByte ASM, &HE9
WriteLong ASM, Addr - ASM - 4
End Sub
Private Sub WriteCall(ByRef ASM As Long, ByRef Addr As Long)
WriteByte ASM, &HE8
WriteLong ASM, Addr - ASM - 4
End Sub
Private Sub WriteLong(ByRef ASM As Long, ByRef Lng As Long)
CopyMemory ByVal ASM, Lng, 4
ASM = ASM + 4
End Sub
Private Sub WriteByte(ByRef ASM As Long, ByRef b As Byte)
CopyMemory ByVal ASM, b, 1
ASM = ASM + 1
End Sub
#End If

复制代码

Common.bas

Option Explicit
Private Type MSGBOXPARAMS
cbSize As Long
hWndOwner As Long
hInstance As Long
lpszText As Long
lpszCaption As Long
dwStyle As Long
lpszIcon As Long
dwContextHelpID As Long
lpfnMsgBoxCallback As Long
dwLanguageId As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type BITMAP
BMType As Long
BMWidth As Long
BMHeight As Long
BMWidthBytes As Long
BMPlanes As Integer
BMBitsPixel As Integer
BMBits As Long
End Type
Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type
Private Type SAFEARRAY1D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds As SAFEARRAYBOUND
End Type
Private Type PICTDESC
cbSizeOfStruct As Long
PicType As Long
hImage As Long
XExt As Long
YExt As Long
End Type
Private Type CLSID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Private Const MAX_PATH As Long = 260
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
FTCreationTime As FILETIME
FTLastAccessTime As FILETIME
FTLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
lpszFileName(0 To ((MAX_PATH * 2) - 1)) As Byte
lpszAlternateFileName(0 To ((14 * 2) - 1)) As Byte
End Type
Private Type VS_FIXEDFILEINFO
dwSignature As Long
dwStrucVersionLo As Integer
dwStrucVersionHi As Integer
dwFileVersionMSLo As Integer
dwFileVersionMSHi As Integer
dwFileVersionLSLo As Integer
dwFileVersionLSHi As Integer
dwProductVersionMSLo As Integer
dwProductVersionMSHi As Integer
dwProductVersionLSLo As Integer
dwProductVersionLSHi As Integer
dwFileFlagsMask As Long
dwFileFlags As Long
dwFileOS As Long
dwFileType As Long
dwFileSubtype As Long
dwFileDateMS As Long
dwFileDateLS As Long
End Type
Private Const LF_FACESIZE As Long = 32
Private Const FW_NORMAL As Long = 400
Private Const FW_BOLD As Long = 700
Private Const DEFAULT_QUALITY As Long = 0
Private 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(0 To ((LF_FACESIZE * 2) - 1)) As Byte
End Type
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function ArrPtr Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Var() As Any) As Long
Private Declare Function MessageBoxIndirect Lib "user32" Alias "MessageBoxIndirectW" (ByRef lpMsgBoxParams As MSGBOXPARAMS) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesW" (ByVal lpFileName As Long) As Long
Private Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesW" (ByVal lpFileName As Long, ByVal dwFileAttributes As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileW" (ByVal lpFileName As Long, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, ByRef lpFileSizeHigh As Long) As Long
Private Declare Function GetFileTime Lib "kernel32" (ByVal hFile As Long, ByVal lpCreationTime As Long, ByVal lpLastAccessTime As Long, ByVal lpLastWriteTime As Long) As Long
Private Declare Function FileTimeToLocalFileTime Lib "kernel32" (ByVal lpFileTime As Long, ByVal lpLocalFileTime As Long) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (ByVal lpFileTime As Long, ByVal lpSystemTime As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileW" (ByVal lpFileName As Long, ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileW" (ByVal hFindFile As Long, ByRef lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function GetVolumePathName Lib "kernel32" Alias "GetVolumePathNameW" (ByVal lpFileName As Long, ByVal lpVolumePathName As Long, ByVal cch As Long) As Long
Private Declare Function GetVolumeInformation Lib "kernel32" Alias "GetVolumeInformationW" (ByVal lpRootPathName As Long, ByVal lpVolumeNameBuffer As Long, ByVal nVolumeNameSize As Long, ByRef lpVolumeSerialNumber As Long, ByRef lpMaximumComponentLength As Long, ByRef lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As Long, ByVal nFileSystemNameSize As Long) As Long
Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryW" (ByVal lpPathName As Long, ByVal lpSecurityAttributes As Long) As Long
Private Declare Function RemoveDirectory Lib "kernel32" Alias "RemoveDirectoryW" (ByVal lpPathName As Long) As Long
Private Declare Function GetCurrentDirectory Lib "kernel32" Alias "GetCurrentDirectoryW" (ByVal nBufferLength As Long, ByVal lpBuffer As Long) As Long
Private Declare Function GetFileVersionInfo Lib "Version" Alias "GetFileVersionInfoW" (ByVal lpFileName As Long, ByVal dwHandle As Long, ByVal dwLen As Long, ByVal lpData As Long) As Long
Private Declare Function GetFileVersionInfoSize Lib "Version" Alias "GetFileVersionInfoSizeW" (ByVal lpFileName As Long, ByVal lpdwHandle As Long) As Long
Private Declare Function VerQueryValue Lib "Version" Alias "VerQueryValueW" (ByVal lpBlock As Long, ByVal lpSubBlock As Long, ByRef lplpBuffer As Long, ByRef puLen As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetCommandLine Lib "kernel32" Alias "GetCommandLineW" () As Long
Private Declare Function PathGetArgs Lib "shlwapi" Alias "PathGetArgsW" (ByVal lpszPath As Long) As Long
Private Declare Function SysReAllocString Lib "oleaut32" (ByVal pbString As Long, ByVal pszStrPtr As Long) As Long
Private Declare Function VarDecFromI8 Lib "oleaut32" (ByVal LoDWord As Long, ByVal HiDWord As Long, ByRef pDecOut As Variant) As Long
Private Declare Function GetModuleFileName Lib "kernel32" Alias "GetModuleFileNameW" (ByVal hModule As Long, ByVal lpFileName As Long, ByVal nSize As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextW" (ByVal hwnd As Long, ByVal lpString As Long, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthW" (ByVal hwnd As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameW" (ByVal hwnd As Long, ByVal lpClassName As Long, ByVal nMaxCount As Long) As Long
Private Declare Function GetSystemWindowsDirectory Lib "kernel32" Alias "GetSystemWindowsDirectoryW" (ByVal lpBuffer As Long, ByVal nSize As Long) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryW" (ByVal lpBuffer As Long, ByVal nSize As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, ByVal lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectW" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GdiAlphaBlend 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 nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal BlendFunc As Long) As Long
Private 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 Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectW" (ByRef lpLogFont As LOGFONT) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function OleTranslateColor Lib "oleaut32" (ByVal Color As Long, ByVal hPal As Long, ByRef RGBResult As Long) As Long
Private Declare Function OleLoadPicture Lib "oleaut32" (ByVal pStream As IUnknown, ByVal lSize As Long, ByVal fRunmode As Long, ByRef riid As Any, ByRef pIPicture As IPicture) As Long
Private Declare Function OleLoadPicturePath Lib "oleaut32" (ByVal lpszPath As Long, ByVal pUnkCaller As Long, ByVal dwReserved As Long, ByVal ClrReserved As OLE_COLOR, ByRef riid As CLSID, ByRef pIPicture As IPicture) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (ByRef pPictDesc As PICTDESC, ByRef riid As Any, ByVal fPictureOwnsHandle As Long, ByRef pIPicture As IPicture) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ByRef pStream As IUnknown) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cbMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cbMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
' (VB-Overwrite)
Public Function MsgBox(ByVal Prompt As String, Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, Optional ByVal Title As String) As VbMsgBoxResult
Dim MSGBOXP As MSGBOXPARAMS
With MSGBOXP
.cbSize = LenB(MSGBOXP)
If (Buttons And vbSystemModal) = 0 Then
If Not Screen.ActiveForm Is Nothing Then
.hWndOwner = Screen.ActiveForm.hwnd
Else
.hWndOwner = GetActiveWindow()
End If
Else
.hWndOwner = GetForegroundWindow()
End If
.hInstance = App.hInstance
.lpszText = StrPtr(Prompt)
If Title = vbNullString Then Title = App.Title
.lpszCaption = StrPtr(Title)
.dwStyle = Buttons
End With
MsgBox = MessageBoxIndirect(MSGBOXP)
End Function
' (VB-Overwrite)
Public Sub SendKeys(ByRef Text As String, Optional ByRef Wait As Boolean)
CreateObject("WScript.Shell").SendKeys Text, Wait
End Sub
' (VB-Overwrite)
Public Function GetAttr(ByVal PathName As String) As VbFileAttribute
Const INVALID_FILE_ATTRIBUTES As Long = (-1)
Const FILE_ATTRIBUTE_NORMAL As Long = &H80
If Left$(PathName, 2) = "\" Then PathName = "UNC" & Mid$(PathName, 3)
Dim dwAttributes As Long
dwAttributes = GetFileAttributes(StrPtr("\\?" & PathName))
If dwAttributes = INVALID_FILE_ATTRIBUTES Then
ERR.Raise 53
ElseIf dwAttributes = FILE_ATTRIBUTE_NORMAL Then
GetAttr = vbNormal
Else
GetAttr = dwAttributes
End If
End Function
' (VB-Overwrite)
Public Sub SetAttr(ByVal PathName As String, ByVal Attributes As VbFileAttribute)
Const FILE_ATTRIBUTE_NORMAL As Long = &H80
Dim dwAttributes As Long
If Attributes = vbNormal Then
dwAttributes = FILE_ATTRIBUTE_NORMAL
Else
If (Attributes And (vbVolume Or vbDirectory Or vbAlias)) <> 0 Then ERR.Raise 5
dwAttributes = Attributes
End If
If Left$(PathName, 2) = "\" Then PathName = "UNC" & Mid$(PathName, 3)
If SetFileAttributes(StrPtr("\\?" & PathName), dwAttributes) = 0 Then ERR.Raise 53
End Sub
' (VB-Overwrite)
Public Sub MkDir(ByVal PathName As String)
If Left$(PathName, 2) = "\" Then PathName = "UNC" & Mid$(PathName, 3)
If CreateDirectory(StrPtr("\\?" & PathName), 0) = 0 Then
Const ERROR_PATH_NOT_FOUND As Long = 3
If ERR.LastDllError = ERROR_PATH_NOT_FOUND Then
ERR.Raise 76
Else
ERR.Raise 75
End If
End If
End Sub
' (VB-Overwrite)
Public Sub RmDir(ByVal PathName As String)
If Left$(PathName, 2) = "\" Then PathName = "UNC" & Mid$(PathName, 3)
If RemoveDirectory(StrPtr("\\?" & PathName)) = 0 Then
Const ERROR_FILE_NOT_FOUND As Long = 2
If ERR.LastDllError = ERROR_FILE_NOT_FOUND Then
ERR.Raise 76
Else
ERR.Raise 75
End If
End If
End Sub
' (VB-Overwrite)
Public Function FileLen(ByVal PathName As String) As Variant
Const INVALID_HANDLE_VALUE As Long = (-1), INVALID_FILE_SIZE As Long = (-1)
Const GENERIC_READ As Long = &H80000000, FILE_SHARE_READ As Long = &H1, OPEN_EXISTING As Long = 3, FILE_FLAG_SEQUENTIAL_SCAN As Long = &H8000000
Dim hFile As Long
If Left$(PathName, 2) = "\" Then PathName = "UNC" & Mid$(PathName, 3)
hFile = CreateFile(StrPtr("\\?" & PathName), GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, 0)
If hFile <> INVALID_HANDLE_VALUE Then
Dim LoDWord As Long, HiDWord As Long
LoDWord = GetFileSize(hFile, HiDWord)
CloseHandle hFile
If LoDWord <> INVALID_FILE_SIZE Then
FileLen = CDec(0)
VarDecFromI8 LoDWord, HiDWord, FileLen
Else
FileLen = Null
End If
Else
ERR.Raise Number:=53, Description:="File not found: '" & PathName & "'"
End If
End Function
' (VB-Overwrite)
Public Function FileDateTime(ByVal PathName As String) As Date
Const INVALID_HANDLE_VALUE As Long = (-1)
Const GENERIC_READ As Long = &H80000000, FILE_SHARE_READ As Long = &H1, OPEN_EXISTING As Long = 3, FILE_FLAG_SEQUENTIAL_SCAN As Long = &H8000000
Dim hFile As Long
If Left$(PathName, 2) = "\" Then PathName = "UNC" & Mid$(PathName, 3)
hFile = CreateFile(StrPtr("\\?" & PathName), GENERIC_READ, FILE_SHARE_READ, 0, OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, 0)
If hFile <> INVALID_HANDLE_VALUE Then
Dim FT(0 To 1) As FILETIME, st As SYSTEMTIME
GetFileTime hFile, 0, 0, VarPtr(FT(0))
FileTimeToLocalFileTime VarPtr(FT(0)), VarPtr(FT(1))
FileTimeToSystemTime VarPtr(FT(1)), VarPtr(st)
FileDateTime = DateSerial(st.wYear, st.wMonth, st.wDay) + TimeSerial(st.wHour, st.wMinute, st.wSecond)
CloseHandle hFile
Else
ERR.Raise Number:=53, Description:="File not found: '" & PathName & "'"
End If
End Function
' (VB-Overwrite)
Public Function Command$()
If InIDE() = False Then
SysReAllocString VarPtr(Command$), PathGetArgs(GetCommandLine())
Command$ = LTrim$(Command$)
Else
Command$ = VBA.Command$()
End If
End Function
Public Function FileExists(ByVal PathName As String) As Boolean
On Error Resume Next
Dim Attributes As VbFileAttribute, ErrVal As Long
Attributes = GetAttr(PathName)
ErrVal = ERR.Number
On Error GoTo 0
If (Attributes And (vbDirectory Or vbVolume)) = 0 And ErrVal = 0 Then FileExists = True
End Function
Public Function AppPath() As String
If InIDE() = False Then
Const MAX_PATH_W As Long = 32767
Dim Buffer As String, RetVal As Long
Buffer = String(MAX_PATH, vbNullChar)
RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH)
If RetVal = MAX_PATH Then ' Path > MAX_PATH
Buffer = String(MAX_PATH_W, vbNullChar)
RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH_W)
End If
If RetVal > 0 Then
Buffer = Left$(Buffer, RetVal)
AppPath = Left$(Buffer, InStrRev(Buffer, ""))
Else
AppPath = App.Path & IIf(Right$(App.Path, 1) = "", "", "")
End If
Else
AppPath = App.Path & IIf(Right$(App.Path, 1) = "", "", "")
End If
End Function
Public Function AppEXEName() As String
If InIDE() = False Then
Const MAX_PATH_W As Long = 32767
Dim Buffer As String, RetVal As Long
Buffer = String(MAX_PATH, vbNullChar)
RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH)
If RetVal = MAX_PATH Then ' Path > MAX_PATH
Buffer = String(MAX_PATH_W, vbNullChar)
RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH_W)
End If
If RetVal > 0 Then
Buffer = Left$(Buffer, RetVal)
Buffer = Right$(Buffer, Len(Buffer) - InStrRev(Buffer, ""))
AppEXEName = Left$(Buffer, InStrRev(Buffer, ".") - 1)
Else
AppEXEName = App.EXEName
End If
Else
AppEXEName = App.EXEName
End If
End Function
Public Function AppMajor() As Integer
If InIDE() = False Then
With GetAppVersionInfo()
AppMajor = .dwFileVersionMSHi
End With
Else
AppMajor = App.Major
End If
End Function
Public Function AppMinor() As Integer
If InIDE() = False Then
With GetAppVersionInfo()
AppMinor = .dwFileVersionMSLo
End With
Else
AppMinor = App.Minor
End If
End Function
Public Function AppRevision() As Integer
If InIDE() = False Then
With GetAppVersionInfo()
AppRevision = .dwFileVersionLSLo
End With
Else
AppRevision = App.Revision
End If
End Function
Private Function GetAppVersionInfo() As VS_FIXEDFILEINFO
Static Done As Boolean, Value As VS_FIXEDFILEINFO
If Done = False Then
Const MAX_PATH_W As Long = 32767
Dim Buffer As String, RetVal As Long
Buffer = String(MAX_PATH, vbNullChar)
RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH)
If RetVal = MAX_PATH Then ' Path > MAX_PATH
Buffer = String(MAX_PATH_W, vbNullChar)
RetVal = GetModuleFileName(0, StrPtr(Buffer), MAX_PATH_W)
End If
If RetVal > 0 Then
Dim ImagePath As String, Length As Long
ImagePath = Left$(Buffer, RetVal)
Length = GetFileVersionInfoSize(StrPtr(ImagePath), 0)
If Length > 0 Then
Dim DataBuffer() As Byte
ReDim DataBuffer(0 To (Length - 1)) As Byte
If GetFileVersionInfo(StrPtr(ImagePath), 0, Length, VarPtr(DataBuffer(0))) <> 0 Then
Dim hData As Long
If VerQueryValue(VarPtr(DataBuffer(0)), StrPtr(""), hData, Length) <> 0 Then
If hData <> 0 Then CopyMemory Value, ByVal hData, LenB(Value)
End If
End If
End If
End If
Done = True
End If
LSet GetAppVersionInfo = Value
End Function
Public Function GetClipboardText() As String
Const CF_UNICODETEXT As Long = 13
Dim lpText As Long, Length As Long
Dim hMem As Long, lpMem As Long
If OpenClipboard(0) <> 0 Then
If IsClipboardFormatAvailable(CF_UNICODETEXT) <> 0 Then
lpText = GetClipboardData(CF_UNICODETEXT)
If lpText <> 0 Then
Length = GlobalSize(lpText)
If Length > 0 Then
lpMem = GlobalLock(lpText)
If lpMem <> 0 Then
GetClipboardText = String((Length \ 2) - 1, vbNullChar)
CopyMemory ByVal StrPtr(GetClipboardText), ByVal lpMem, Length
GlobalUnlock lpMem
End If
End If
End If
End If
CloseClipboard
End If
End Function
Public Sub SetClipboardText(ByRef Text As String)
Const CF_UNICODETEXT As Long = 13
Const GMEM_MOVEABLE As Long = &H2
Dim Buffer As String, Length As Long
Dim hMem As Long, lpMem As Long
If OpenClipboard(0) <> 0 Then
EmptyClipboard
Buffer = Text & vbNullChar
Length = LenB(Buffer)
hMem = GlobalAlloc(GMEM_MOVEABLE, Length)
If hMem <> 0 Then
lpMem = GlobalLock(hMem)
If lpMem <> 0 Then
CopyMemory ByVal lpMem, ByVal StrPtr(Buffer), Length
GlobalUnlock hMem
SetClipboardData CF_UNICODETEXT, hMem
End If
End If
CloseClipboard
End If
End Sub
Public Function AccelCharCode(ByVal Caption As String) As Integer
If Caption = vbNullString Then Exit Function
Dim Pos As Long, Length As Long
Length = Len(Caption)
Pos = Length
Do
If Mid$(Caption, Pos, 1) = "&" And Pos < Length Then
AccelCharCode = Asc(UCase$(Mid$(Caption, Pos + 1, 1)))
If Pos > 1 Then
If Mid$(Caption, Pos - 1, 1) = "&" Then AccelCharCode = 0
Else
If AccelCharCode = vbKeyUp Then AccelCharCode = 0
End If
If AccelCharCode <> 0 Then Exit Do
End If
Pos = Pos - 1
Loop Until Pos = 0
End Function
Public Function ProperControlName(ByVal Control As VB.Control) As String
Dim Index As Long
On Error Resume Next
Index = Control.Index
If ERR.Number <> 0 Or Index < 0 Then ProperControlName = Control.Name Else ProperControlName = Control.Name & "(" & Index & ")"
On Error GoTo 0
End Function
Public Function GetTopUserControl(ByVal UserControl As Object) As VB.UserControl
If UserControl Is Nothing Then Exit Function
Dim TopUserControl As VB.UserControl, TempUserControl As VB.UserControl
CopyMemory TempUserControl, ObjPtr(UserControl), 4
Set TopUserControl = TempUserControl
CopyMemory TempUserControl, 0&, 4
With TopUserControl
If .ParentControls.Count > 0 Then
Dim OldParentControlsType As VBRUN.ParentControlsType
OldParentControlsType = .ParentControls.ParentControlsType
.ParentControls.ParentControlsType = vbExtender
If TypeOf .ParentControls(0) Is VB.VBControlExtender Then
.ParentControls.ParentControlsType = vbNoExtender
CopyMemory TempUserControl, ObjPtr(.ParentControls(0)), 4
Set TopUserControl = TempUserControl
CopyMemory TempUserControl, 0&, 4
Dim TempParentControlsType As VBRUN.ParentControlsType
Do
With TopUserControl
If .ParentControls.Count = 0 Then Exit Do
TempParentControlsType = .ParentControls.ParentControlsType
.ParentControls.ParentControlsType = vbExtender
If TypeOf .ParentControls(0) Is VB.VBControlExtender Then
.ParentControls.ParentControlsType = vbNoExtender
CopyMemory TempUserControl, ObjPtr(.ParentControls(0)), 4
Set TopUserControl = TempUserControl
CopyMemory TempUserControl, 0&, 4
.ParentControls.ParentControlsType = TempParentControlsType
Else
.ParentControls.ParentControlsType = TempParentControlsType
Exit Do
End If
End With
Loop
End If
.ParentControls.ParentControlsType = OldParentControlsType
End If
End With
Set GetTopUserControl = TopUserControl
End Function
Public Function MousePointerID(ByVal MousePointer As Integer) As Long
Select Case MousePointer
Case vbArrow
Const IDC_ARROW As Long = 32512
MousePointerID = IDC_ARROW
Case vbCrosshair
Const IDC_CROSS As Long = 32515
MousePointerID = IDC_CROSS
Case vbIbeam
Const IDC_IBEAM As Long = 32513
MousePointerID = IDC_IBEAM
Case vbIconPointer ' Obselete, replaced Icon with Hand
Const IDC_HAND As Long = 32649
MousePointerID = IDC_HAND
Case vbSizePointer, vbSizeAll
Const IDC_SIZEALL As Long = 32646
MousePointerID = IDC_SIZEALL
Case vbSizeNESW
Const IDC_SIZENESW As Long = 32643
MousePointerID = IDC_SIZENESW
Case vbSizeNS
Const IDC_SIZENS As Long = 32645
MousePointerID = IDC_SIZENS
Case vbSizeNWSE
Const IDC_SIZENWSE As Long = 32642
MousePointerID = IDC_SIZENWSE
Case vbSizeWE
Const IDC_SIZEWE As Long = 32644
MousePointerID = IDC_SIZEWE
Case vbUpArrow
Const IDC_UPARROW As Long = 32516
MousePointerID = IDC_UPARROW
Case vbHourglass
Const IDC_WAIT As Long = 32514
MousePointerID = IDC_WAIT
Case vbNoDrop
Const IDC_NO As Long = 32648
MousePointerID = IDC_NO
Case vbArrowHourglass
Const IDC_APPSTARTING As Long = 32650
MousePointerID = IDC_APPSTARTING
Case vbArrowQuestion
Const IDC_HELP As Long = 32651
MousePointerID = IDC_HELP
Case 16
Const IDC_WAITCD As Long = 32663 ' Undocumented
MousePointerID = IDC_WAITCD
End Select
End Function
Public Function OLEFontIsEqual(ByVal Font As StdFont, ByVal FontOther As StdFont) As Boolean
If Font Is Nothing Then
If FontOther Is Nothing Then OLEFontIsEqual = True
ElseIf FontOther Is Nothing Then
If Font Is Nothing Then OLEFontIsEqual = True
Else
If Font.Name = FontOther.Name And Font.Size = FontOther.Size And Font.Charset = FontOther.Charset And Font.Weight = FontOther.Weight And _
Font.Underline = FontOther.Underline And Font.Italic = FontOther.Italic And Font.Strikethrough = FontOther.Strikethrough Then
OLEFontIsEqual = True
End If
End If
End Function
Public Function CreateGDIFontFromOLEFont(ByVal Font As StdFont) As Long
Dim LF As LOGFONT, FontName As String
With LF
FontName = Left$(Font.Name, LF_FACESIZE)
CopyMemory .LFFaceName(0), ByVal StrPtr(FontName), LenB(FontName)
.LFHeight = -MulDiv(CLng(Font.Size), DPI_Y(), 72)
If Font.Bold = True Then .LFWeight = FW_BOLD Else .LFWeight = FW_NORMAL
If Font.Italic = True Then .LFItalic = 1 Else .LFItalic = 0
If Font.Strikethrough = True Then .LFStrikeOut = 1 Else .LFStrikeOut = 0
If Font.Underline = True Then .LFUnderline = 1 Else .LFUnderline = 0
.LFQuality = DEFAULT_QUALITY
.LFCharset = CByte(Font.Charset And &HFF)
End With
CreateGDIFontFromOLEFont = CreateFontIndirect(LF)
End Function
Public Function CloneOLEFont(ByVal Font As IFont) As StdFont
Font.Clone CloneOLEFont
End Function
Public Function GDIFontFromOLEFont(ByVal Font As IFont) As Long
GDIFontFromOLEFont = Font.hFont
End Function
Public Function GetNumberGroupDigit() As String
GetNumberGroupDigit = Mid$(FormatNumber(1000, 0, , , vbTrue), 2, 1)
If GetNumberGroupDigit = "0" Then GetNumberGroupDigit = vbNullString
End Function
Public Function GetDecimalChar() As String
GetDecimalChar = Mid$(CStr(1.1), 2, 1)
End Function
Public Function IsFormLoaded(ByVal FormName As String) As Boolean
Dim i As Integer
For i = 0 To Forms.Count - 1
If StrComp(Forms(i).Name, FormName, vbTextCompare) = 0 Then
IsFormLoaded = True
Exit For
End If
Next i
End Function
Public Function GetWindowTitle(ByVal hwnd As Long) As String
Dim Buffer As String
Buffer = String(GetWindowTextLength(hwnd) + 1, vbNullChar)
GetWindowText hwnd, StrPtr(Buffer), Len(Buffer)
GetWindowTitle = Left$(Buffer, Len(Buffer) - 1)
End Function
Public Function GetWindowClassName(ByVal hwnd As Long) As String
Dim Buffer As String, RetVal As Long
Buffer = String(256, vbNullChar)
RetVal = GetClassName(hwnd, StrPtr(Buffer), Len(Buffer))
If RetVal <> 0 Then GetWindowClassName = Left$(Buffer, RetVal)
End Function
Public Function GetFormTitleBarHeight(ByVal Form As VB.Form) As Single
Const SM_CYCAPTION As Long = 4, SM_CYMENU As Long = 15
Const SM_CYSIZEFRAME As Long = 33, SM_CYFIXEDFRAME As Long = 8
Dim cy As Long
cy = GetSystemMetrics(SM_CYCAPTION)
If GetMenu(Form.hwnd) <> 0 Then cy = cy + GetSystemMetrics(SM_CYMENU)
Select Case Form.BorderStyle
Case vbSizable, vbSizableToolWindow
cy = cy + GetSystemMetrics(SM_CYSIZEFRAME)
Case vbFixedSingle, vbFixedDialog, vbFixedToolWindow
cy = cy + GetSystemMetrics(SM_CYFIXEDFRAME)
End Select
If cy > 0 Then GetFormTitleBarHeight = Form.ScaleY(cy, vbPixels, Form.ScaleMode)
End Function
Public Function GetFormNonScaleHeight(ByVal Form As VB.Form) As Single
Const SM_CYCAPTION As Long = 4, SM_CYMENU As Long = 15
Const SM_CYSIZEFRAME As Long = 33, SM_CYFIXEDFRAME As Long = 8
Dim cy As Long
cy = GetSystemMetrics(SM_CYCAPTION)
If GetMenu(Form.hwnd) <> 0 Then cy = cy + GetSystemMetrics(SM_CYMENU)
Select Case Form.BorderStyle
Case vbSizable, vbSizableToolWindow
cy = cy + (GetSystemMetrics(SM_CYSIZEFRAME) * 2)
Case vbFixedSingle, vbFixedDialog, vbFixedToolWindow
cy = cy + (GetSystemMetrics(SM_CYFIXEDFRAME) * 2)
End Select
If cy > 0 Then GetFormNonScaleHeight = Form.ScaleY(cy, vbPixels, Form.ScaleMode)
End Function
Public Sub SetWindowRedraw(ByVal hwnd As Long, ByVal Enabled As Boolean)
Const WM_SETREDRAW As Long = &HB
SendMessage hwnd, WM_SETREDRAW, IIf(Enabled = True, 1, 0), ByVal 0&
If Enabled = True Then
Const RDW_UPDATENOW As Long = &H100, RDW_INVALIDATE As Long = &H1, RDW_ERASE As Long = &H4, RDW_ALLCHILDREN As Long = &H80
RedrawWindow hwnd, 0, 0, RDW_UPDATENOW Or RDW_INVALIDATE Or RDW_ERASE Or RDW_ALLCHILDREN
End If
End Sub
Public Function GetWindowsDir() As String
Static Done As Boolean, Value As String
If Done = False Then
Dim Buffer As String
Buffer = String(MAX_PATH, vbNullChar)
If GetSystemWindowsDirectory(StrPtr(Buffer), MAX_PATH) <> 0 Then
Value = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
Value = Value & IIf(Right$(Value, 1) = "", "", "")
End If
Done = True
End If
GetWindowsDir = Value
End Function
Public Function GetSystemDir() As String
Static Done As Boolean, Value As String
If Done = False Then
Dim Buffer As String
Buffer = String(MAX_PATH, vbNullChar)
If GetSystemDirectory(StrPtr(Buffer), MAX_PATH) <> 0 Then
Value = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
Value = Value & IIf(Right$(Value, 1) = "", "", "")
End If
Done = True
End If
GetSystemDir = Value
End Function
Public Function GetShiftStateFromParam(ByVal wParam As Long) As ShiftConstants
Const MK_SHIFT As Long = &H4, MK_CONTROL As Long = &H8
If (wParam And MK_SHIFT) = MK_SHIFT Then GetShiftStateFromParam = vbShiftMask
If (wParam And MK_CONTROL) = MK_CONTROL Then GetShiftStateFromParam = GetShiftStateFromParam Or vbCtrlMask
If GetKeyState(vbKeyMenu) < 0 Then GetShiftStateFromParam = GetShiftStateFromParam Or vbAltMask
End Function
Public Function GetMouseStateFromParam(ByVal wParam As Long) As MouseButtonConstants
Const MK_LBUTTON As Long = &H1, MK_RBUTTON As Long = &H2, MK_MBUTTON As Long = &H10
If (wParam And MK_LBUTTON) = MK_LBUTTON Then GetMouseStateFromParam = vbLeftButton
If (wParam And MK_RBUTTON) = MK_RBUTTON Then GetMouseStateFromParam = GetMouseStateFromParam Or vbRightButton
If (wParam And MK_MBUTTON) = MK_MBUTTON Then GetMouseStateFromParam = GetMouseStateFromParam Or vbMiddleButton
End Function
Public Function GetShiftStateFromMsg() As ShiftConstants
If GetKeyState(vbKeyShift) < 0 Then GetShiftStateFromMsg = vbShiftMask
If GetKeyState(vbKeyControl) < 0 Then GetShiftStateFromMsg = GetShiftStateFromMsg Or vbCtrlMask
If GetKeyState(vbKeyMenu) < 0 Then GetShiftStateFromMsg = GetShiftStateFromMsg Or vbAltMask
End Function
Public Function GetMouseStateFromMsg() As MouseButtonConstants
If GetKeyState(vbLeftButton) < 0 Then GetMouseStateFromMsg = vbLeftButton
If GetKeyState(vbRightButton) < 0 Then GetMouseStateFromMsg = GetMouseStateFromMsg Or vbRightButton
If GetKeyState(vbMiddleButton) < 0 Then GetMouseStateFromMsg = GetMouseStateFromMsg Or vbMiddleButton
End Function
Public Function GetShiftState() As ShiftConstants
GetShiftState = (-vbShiftMask * KeyPressed(vbKeyShift))
GetShiftState = GetShiftState Or (-vbCtrlMask * KeyPressed(vbKeyControl))
GetShiftState = GetShiftState Or (-vbAltMask * KeyPressed(vbKeyMenu))
End Function
Public Function GetMouseState() As MouseButtonConstants
Const SM_SWAPBUTTON As Long = 23
' GetAsyncKeyState requires a mapping of physical mouse buttons to logical mouse buttons.
GetMouseState = (-vbLeftButton * KeyPressed(IIf(GetSystemMetrics(SM_SWAPBUTTON) = 0, vbLeftButton, vbRightButton)))
GetMouseState = GetMouseState Or (-vbRightButton * KeyPressed(IIf(GetSystemMetrics(SM_SWAPBUTTON) = 0, vbRightButton, vbLeftButton)))
GetMouseState = GetMouseState Or (-vbMiddleButton * KeyPressed(vbMiddleButton))
End Function
Public Function KeyToggled(ByVal KeyCode As KeyCodeConstants) As Boolean
KeyToggled = CBool(LoByte(GetKeyState(KeyCode)) = 1)
End Function
Public Function KeyPressed(ByVal KeyCode As KeyCodeConstants) As Boolean
KeyPressed = CBool((GetAsyncKeyState(KeyCode) And &H8000&) = &H8000&)
End Function
Public Function InIDE(Optional ByRef b As Boolean = True) As Boolean
If b = True Then Debug.Assert Not InIDE(InIDE) Else b = True
End Function
Public Function PtrToObj(ByVal ObjectPointer As Long) As Object
Dim TempObj As Object
CopyMemory TempObj, ObjectPointer, 4
Set PtrToObj = TempObj
CopyMemory TempObj, 0&, 4
End Function
Public Function ProcPtr(ByVal Address As Long) As Long
ProcPtr = Address
End Function
Public Function LoByte(ByVal Word As Integer) As Byte
LoByte = Word And &HFF
End Function
Public Function HiByte(ByVal Word As Integer) As Byte
HiByte = (Word And &HFF00&) \ &H100
End Function
Public Function MakeWord(ByVal LoByte As Byte, ByVal HiByte As Byte) As Integer
If (HiByte And &H80) <> 0 Then
MakeWord = ((HiByte * &H100&) Or LoByte) Or &HFFFF0000
Else
MakeWord = (HiByte * &H100) Or LoByte
End If
End Function
Public Function LoWord(ByVal DWord As Long) As Integer
If DWord And &H8000& Then
LoWord = DWord Or &HFFFF0000
Else
LoWord = DWord And &HFFFF&
End If
End Function
Public Function HiWord(ByVal DWord As Long) As Integer
HiWord = (DWord And &HFFFF0000) \ &H10000
End Function
Public Function MakeDWord(ByVal LoWord As Integer, ByVal HiWord As Integer) As Long
MakeDWord = (CLng(HiWord) * &H10000) Or (LoWord And &HFFFF&)
End Function
Public Function Get_X_lParam(ByVal lParam As Long) As Long
Get_X_lParam = lParam And &H7FFF&
If lParam And &H8000& Then Get_X_lParam = Get_X_lParam Or &HFFFF8000
End Function
Public Function Get_Y_lParam(ByVal lParam As Long) As Long
Get_Y_lParam = (lParam And &H7FFF0000) \ &H10000
If lParam And &H80000000 Then Get_Y_lParam = Get_Y_lParam Or &HFFFF8000
End Function
Public Function UTF16_To_UTF8(ByRef Source As String) As Byte()
Const CP_UTF8 As Long = 65001
Dim Length As Long, Pointer As Long, Size As Long
Length = Len(Source)
Pointer = StrPtr(Source)
Size = WideCharToMultiByte(CP_UTF8, 0, Pointer, Length, 0, 0, 0, 0)
If Size > 0 Then
Dim Buffer() As Byte
ReDim Buffer(0 To Size - 1) As Byte
WideCharToMultiByte CP_UTF8, 0, Pointer, Length, VarPtr(Buffer(0)), Size, 0, 0
UTF16_To_UTF8 = Buffer()
End If
End Function
Public Function UTF8_To_UTF16(ByRef Source() As Byte) As String
If (0 / 1) + (Not Not Source()) = 0 Then Exit Function
Const CP_UTF8 As Long = 65001
Dim Size As Long, Pointer As Long, Length As Long
Size = UBound(Source) - LBound(Source) + 1
Pointer = VarPtr(Source(LBound(Source)))
Length = MultiByteToWideChar(CP_UTF8, 0, Pointer, Size, 0, 0)
If Length > 0 Then
UTF8_To_UTF16 = Space$(Length)
MultiByteToWideChar CP_UTF8, 0, Pointer, Size, StrPtr(UTF8_To_UTF16), Length
End If
End Function
Public Function StrToVar(ByVal Text As String) As Variant
If Text = vbNullString Then
StrToVar = Empty
Else
Dim b() As Byte
b() = Text
StrToVar = b()
End If
End Function
Public Function VarToStr(ByVal Bytes As Variant) As String
If IsEmpty(Bytes) Then
VarToStr = vbNullString
Else
Dim b() As Byte
b() = Bytes
VarToStr = b()
End If
End Function
Public Function UnsignedAdd(ByVal Start As Long, ByVal Incr As Long) As Long
UnsignedAdd = ((Start Xor &H80000000) + Incr) Xor &H80000000
End Function
Public Function CUIntToInt(ByVal Value As Long) As Integer
Const OFFSET_2 As Long = 65536
Const MAXINT_2 As Integer = 32767
If Value < 0 Or Value >= OFFSET_2 Then ERR.Raise 6
If Value <= MAXINT_2 Then
CUIntToInt = Value
Else
CUIntToInt = Value - OFFSET_2
End If
End Function
Public Function CIntToUInt(ByVal Value As Integer) As Long
Const OFFSET_2 As Long = 65536
If Value < 0 Then
CIntToUInt = Value + OFFSET_2
Else
CIntToUInt = Value
End If
End Function
Public Function CULngToLng(ByVal Value As Double) As Long
Const OFFSET_4 As Double = 4294967296#
Const MAXINT_4 As Long = 2147483647
If Value < 0 Or Value >= OFFSET_4 Then ERR.Raise 6
If Value <= MAXINT_4 Then
CULngToLng = Value
Else
CULngToLng = Value - OFFSET_4
End If
End Function
Public Function CLngToULng(ByVal Value As Long) As Double
Const OFFSET_4 As Double = 4294967296#
If Value < 0 Then
CLngToULng = Value + OFFSET_4
Else
CLngToULng = Value
End If
End Function
Public Function DPI_X() As Long
Const LOGPIXELSX As Long = 88
Dim hDCScreen As Long
hDCScreen = GetDC(0)
If hDCScreen <> 0 Then
DPI_X = GetDeviceCaps(hDCScreen, LOGPIXELSX)
ReleaseDC 0, hDCScreen
End If
End Function
Public Function DPI_Y() As Long
Const LOGPIXELSY As Long = 90
Dim hDCScreen As Long
hDCScreen = GetDC(0)
If hDCScreen <> 0 Then
DPI_Y = GetDeviceCaps(hDCScreen, LOGPIXELSY)
ReleaseDC 0, hDCScreen
End If
End Function
Public Function DPICorrectionFactor() As Single
Static Done As Boolean, Value As Single
If Done = False Then
Value = ((96 / DPI_X()) * 15) / Screen.TwipsPerPixelX
Done = True
End If
' Returns exactly 1 when no corrections are required.
DPICorrectionFactor = Value
End Function
Public Function CHimetricToPixel_X(ByVal Width As Long) As Long
Const HIMETRIC_PER_INCH As Long = 2540
CHimetricToPixel_X = (Width * DPI_X()) / HIMETRIC_PER_INCH
End Function
Public Function CHimetricToPixel_Y(ByVal Height As Long) As Long
Const HIMETRIC_PER_INCH As Long = 2540
CHimetricToPixel_Y = (Height * DPI_Y()) / HIMETRIC_PER_INCH
End Function
Public Function PixelsPerDIP_X() As Single
Static Done As Boolean, Value As Single
If Done = False Then
Value = (DPI_X() / 96)
Done = True
End If
PixelsPerDIP_X = Value
End Function
Public Function PixelsPerDIP_Y() As Single
Static Done As Boolean, Value As Single
If Done = False Then
Value = (DPI_Y() / 96)
Done = True
End If
PixelsPerDIP_Y = Value
End Function
Public Function WinColor(ByVal Color As Long, Optional ByVal hPal As Long) As Long
If OleTranslateColor(Color, hPal, WinColor) <> 0 Then WinColor = -1
End Function
Public Function PictureFromByteStream(ByRef ByteStream As Variant) As IPictureDisp
Const GMEM_MOVEABLE As Long = &H2
Dim IID As CLSID, Stream As IUnknown, NewPicture As IPicture
Dim b() As Byte, ByteCount As Long
Dim hMem As Long, lpMem As Long
With IID
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(3) = &HAA
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
If VarType(ByteStream) = (vbArray + vbByte) Then
b() = ByteStream
ByteCount = (UBound(b()) - LBound(b())) + 1
hMem = GlobalAlloc(GMEM_MOVEABLE, ByteCount)
If hMem <> 0 Then
lpMem = GlobalLock(hMem)
If lpMem <> 0 Then
CopyMemory ByVal lpMem, b(LBound(b())), ByteCount
GlobalUnlock hMem
If CreateStreamOnHGlobal(hMem, 1, Stream) = 0 Then
If OleLoadPicture(Stream, ByteCount, 0, IID, NewPicture) = 0 Then Set PictureFromByteStream = NewPicture
End If
End If
End If
End If
End Function
Public Function PictureFromPath(ByVal PathName As String) As IPictureDisp
Dim IID As CLSID, NewPicture As IPicture
With IID
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(3) = &HAA
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
If OleLoadPicturePath(StrPtr(PathName), 0, 0, 0, IID, NewPicture) = 0 Then Set PictureFromPath = NewPicture
End Function
Public Function PictureFromHandle(ByVal Handle As Long, ByVal PicType As VBRUN.PictureTypeConstants) As IPictureDisp
If Handle = 0 Then Exit Function
Dim PICD As PICTDESC, IID As CLSID, NewPicture As IPicture
With PICD
.cbSizeOfStruct = LenB(PICD)
.PicType = PicType
.hImage = Handle
End With
With IID
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(3) = &HAA
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
If OleCreatePictureIndirect(PICD, IID, 1, NewPicture) = 0 Then Set PictureFromHandle = NewPicture
End Function
Public Function BitmapHandleFromPicture(ByVal Picture As IPictureDisp, Optional ByVal BackColor As OLE_COLOR) As Long
If Picture Is Nothing Then Exit Function
With Picture
If .Handle <> 0 Then
Dim hDCScreen As Long, hDC As Long, hBmp As Long, hBmpOld As Long
Dim cx As Long, cy As Long, Brush As Long
cx = CHimetricToPixel_X(.Width)
cy = CHimetricToPixel_Y(.Height)
Brush = CreateSolidBrush(WinColor(BackColor))
hDCScreen = GetDC(0)
If hDCScreen <> 0 Then
hDC = CreateCompatibleDC(hDCScreen)
If hDC <> 0 Then
hBmp = CreateCompatibleBitmap(hDCScreen, cx, cy)
If hBmp <> 0 Then
hBmpOld = SelectObject(hDC, hBmp)
If .Type = vbPicTypeIcon Then
Const DI_NORMAL As Long = &H3
DrawIconEx hDC, 0, 0, .Handle, cx, cy, 0, Brush, DI_NORMAL
Else
Dim RC As RECT
RC.Right = cx
RC.Bottom = cy
FillRect hDC, RC, Brush
.Render hDC Or 0&, 0&, 0&, cx Or 0&, cy Or 0&, 0&, .Height, .Width, -.Height, ByVal 0&
End If
SelectObject hDC, hBmpOld
BitmapHandleFromPicture = hBmp
End If
DeleteDC hDC
End If
ReleaseDC 0, hDCScreen
End If
DeleteObject Brush
End If
End With
End Function
Public Sub RenderPicture(ByVal Picture As IPicture, ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, Optional ByVal cx As Long, Optional ByVal cy As Long, Optional ByRef RenderFlag As Integer)
' RenderFlag is passed as a optional parameter ByRef.
' It is ignored for icons and metafiles.
' 0 = render method unknown, determine it and update parameter
' 1 = StdPicture.Render
' 2 = GdiAlphaBlend
If Picture Is Nothing Then Exit Sub
With Picture
If .Handle <> 0 Then
If cx = 0 Then cx = CHimetricToPixel_X(.Width)
If cy = 0 Then cy = CHimetricToPixel_Y(.Height)
If .Type = vbPicTypeIcon Then
Const DI_NORMAL As Long = &H3
DrawIconEx hDC, X, Y, .Handle, cx, cy, 0, 0, DI_NORMAL
Else
Dim HasAlpha As Boolean
If .Type = vbPicTypeBitmap Then
If RenderFlag = 0 Then
Const PICTURE_TRANSPARENT As Long = &H2
If (.Attributes And PICTURE_TRANSPARENT) = 0 Then ' Exclude GIF
Dim Bmp As BITMAP
GetObjectAPI .Handle, LenB(Bmp), Bmp
If Bmp.BMBitsPixel = 32 And Bmp.BMBits <> 0 Then
Dim SA1D As SAFEARRAY1D, b() As Byte
With SA1D
.cDims = 1
.fFeatures = 0
.cbElements = 1
.cLocks = 0
.pvData = Bmp.BMBits
.Bounds.lLbound = 0
.Bounds.cElements = Bmp.BMWidthBytes * Bmp.BMHeight
End With
CopyMemory ByVal ArrPtr(b()), VarPtr(SA1D), 4
Dim i As Long, j As Long, Pos As Long
For i = 0 To (Abs(Bmp.BMHeight) - 1)
Pos = i * Bmp.BMWidthBytes
For j = (Pos + 3) To (Pos + Bmp.BMWidthBytes - 1) Step 4
If HasAlpha = False Then HasAlpha = (b(j) > 0)
If HasAlpha = True Then
If b(j - 1) > b(j) Then
HasAlpha = False
i = Abs(Bmp.BMHeight) - 1
Exit For
ElseIf b(j - 2) > b(j) Then
HasAlpha = False
i = Abs(Bmp.BMHeight) - 1
Exit For
ElseIf b(j - 3) > b(j) Then
HasAlpha = False
i = Abs(Bmp.BMHeight) - 1
Exit For
End If
End If
Next j
Next i
CopyMemory ByVal ArrPtr(b()), 0&, 4
End If
End If
If HasAlpha = False Then RenderFlag = 1 Else RenderFlag = 2
ElseIf RenderFlag = 2 Then
HasAlpha = True
End If
End If
If HasAlpha = False Then
.Render hDC Or 0&, X Or 0&, Y Or 0&, cx Or 0&, cy Or 0&, 0&, .Height, .Width, -.Height, ByVal 0&
Else
Dim hDCBmp As Long, hBmpOld As Long
hDCBmp = CreateCompatibleDC(0)
If hDCBmp <> 0 Then
hBmpOld = SelectObject(hDCBmp, .Handle)
GdiAlphaBlend hDC, X, Y, cx, cy, hDCBmp, 0, 0, CHimetricToPixel_X(.Width), CHimetricToPixel_Y(.Height), &H1FF0000
SelectObject hDCBmp, hBmpOld
DeleteDC hDCBmp
End If
End If
End If
End If
End With
End Sub

复制代码

GoogleTranslate.bas

'Google Translate 模块
'需添加cStringBuilder.cls 和 JSON.cls两个类模块
'原作者：巴西_prince
'原网站链接：https://cloud.tencent.com/developer/article/1496152
'原发布时间：2019-08-28
'修改者：马云爱逛京东
'修改时间：2019-10-27
'修改内容：整理了翻译的一些函数/子过程，新增翻译函数Translate
Option Explicit
Public JSO As New JSON
Public Enum tLang
ChineseSimplified = 0 'zh-CN
English = 1 'en
ChineseTraditional = 2 'zh-TW
Russian = 3 'ru
German = 4
French = 5
Japanese = 6
Korean = 7
End Enum
''翻译
Public Function Translate(ByVal Text As String, Optional ByVal Language As tLang = ChineseSimplified) As String
On Error GoTo Err01
Dim CenterData As String, strOut As String
CenterData = GetData(GOOGLEURL(Text, Language))
Dim j As Object, i As Integer
Set j = JSO.parse(CenterData)
For i = 1 To j(1)(1).Count
strOut = strOut & j(1)(i)(1)
Next
Translate = strOut
Exit Function
Err01:
Translate = strOut
Debug.Print "发生了某些错误。"
Exit Function
End Function
''地址拼接
Public Function GOOGLEURL(ByVal Text As String, ByVal Lang As tLang) As String
Dim TKK As String
TKK = Split(get_regdata(GetData("https://translate.google.cn"), "tkk:.*?,")(0), "'")(1)
Dim U As String, data As String, TL As String
Select Case Lang
Case ChineseSimplified
TL = "zh-CN"
Case English
TL = "en"
Case ChineseTraditional
TL = "zh-TW"
Case Russian
TL = "ru"
Case German
TL = "de"
Case French
TL = "fr"
Case Japanese
TL = "ja"
Case Korean
TL = "ko"
End Select
data = Replace(Text, vbCrLf, "\r\n")
U = "https://translate.google.cn/translate_a/single?client=webapp&sl=auto&tl=" & TL & "&hl=zh-CN&dt=at&dt=bd&dt=ex&dt=ld&dt=md&" & _
"dt=qca&dt=rw&dt=rm&dt=ss&dt=t&dt=gt&source=bh&ssel=0&tsel=0&kc=1&tk=" & TK(data, TKK) & _
"&q=" & URLEncodeGbk(data)
GOOGLEURL = U
End Function
''地址转换
Public Function URLEncodeGbk(nStr As String) As String
Dim js As Object
Set js = CreateObject("ScriptControl")
js.Language = "JScript"
js.addcode ("function b(a) {return encodeURIComponent(a)}")
URLEncodeGbk = js.eval("b('" & nStr & "')")
End Function
''计算TK
Public Function TK(t As String, TKK As String) As String
Dim js As Object
Set js = CreateObject("ScriptControl")
js.Language = "JScript"
js.addcode ("function b(a, b) {for (var d = 0; d < b.length - 2; d += 3) {var c = b.charAt(d + 2)," & _
"c = 'a' <= c ? c.charCodeAt(0) - 87 : Number(c),c = '+' == b.charAt(d + 1) ? a >>> c : a " & _
"<< c,a = '+' == b.charAt(d) ? a + c & 4294967295 : a ^ c}return a};function tk(a, TKK) {for " & _
"(var e = TKK.split('.'), h = Number(e[0]) || 0, g = [], d = 0, f = 0; f < a.length; f++) {var c =" & _
" a.charCodeAt(f);128 > c ?g[d++] = c : (2048 > c ?g[d++] = c >> 6 | 192 : (55296 == (c & 64512) && " & _
"f + 1 < a.length && 56320 == (a.charCodeAt(f + 1) & 64512) ?(c = 65536 + ((c & 1023) << 10) +" & _
" (a.charCodeAt(++f) & 1023), g[d++] = c >> 18 | 240, g[d++] = c >> 12 & 63 | 128) : g[d++] = c >> " & _
"12 | 224, g[d++] = c >> 6 & 63 | 128), g[d++] = c & 63 | 128)}a = h;for (d = 0; d < g.length; d++)a " & _
"+= g[d], a = b(a, '+-a^+6');a = b(a, '+-3^+b+-f');a ^= Number(e[1]) || 0;0 > a && (a = (a & 2147483647) " & _
"+ 2147483648);a %= 1E6;return a.toString() + '.' + (a ^ h)}")
TK = js.eval("tk('" & t & "','" & TKK & "')")
End Function
''正则表达式函数
Public Function get_regdata(ByVal str As Variant, ByVal rexData As String) As Variant
Dim mRegExp As Object
Dim mMatches As Object
Dim mMatch As Object
Dim arr() As Variant
Set mRegExp = CreateObject("Vbscript.Regexp")
With mRegExp
.Global = True
.IgnoreCase = True
.Pattern = rexData
Set mMatches = .Execute(str)
ReDim arr(mMatches.Count)
Dim i As Integer
i = 0
For Each mMatch In mMatches
arr(i) = mMatch.Value
i = i + 1
Next
End With
get_regdata = arr
Set mRegExp = Nothing
Set mMatches = Nothing
End Function
''GET数据
Public Function GetData(ByVal url As String) As Variant
On Error GoTo ERR:
Dim XMLHTTP As Object
Dim zflx As String
Dim bty() As Byte
Set XMLHTTP = CreateObject("Microsoft.XMLHTTP")
XMLHTTP.Open "get", url, True
' XMLHTTP.setrequestheader "Content-Type", "application/x-www-form-urlencoded"
' XMLHTTP.setrequestheader "User-Agent", "Mozilla/5.0 (Windows NT 10; Win64; x64; rv:66.0) Gecko/20191027 Firefox/70.0"
XMLHTTP.send
While XMLHTTP.ReadyState <> 4
DoEvents
Wend
zflx = XMLHTTP.ResponseText
GetData = zflx
Set XMLHTTP = Nothing
Exit Function
ERR:
GetData = ""
End Function

复制代码

iniReadWrite.bas

Public Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
'读取
Public Function ReadIniKeyValue(ByRef IniFileName As String, ByVal Section As String, ByVal key As String, Optional ByVal DefaultValue As String = vbNullString) As String
Dim stemp As String * 256
Dim nlen As Integer
stemp = Space$(256)
nlen = GetPrivateProfileString(Section, key, DefaultValue, stemp, 255, App.Path & "" & IniFileName)
ReadIniKeyValue = Left$(stemp, nlen)
End Function
'写入
Public Sub WriteIniKeyValue(ByRef IniFileName As String, ByVal Section As String, ByVal key As String, ByVal Value As String)
Dim buff As String * 256, i As Integer
buff = Value + Chr(0)
WritePrivateProfileString Section, key, buff, App.Path & "" & IniFileName
End Sub

复制代码

VisualStyles.bas

Option Explicit
Public Declare Function ActivateVisualStyles Lib "uxtheme" Alias "SetWindowTheme" (ByVal hwnd As Long, Optional ByVal pszSubAppName As Long = 0, Optional ByVal pszSubIdList As Long = 0) As Long
Public Declare Function RemoveVisualStyles Lib "uxtheme" Alias "SetWindowTheme" (ByVal hwnd As Long, Optional ByRef pszSubAppName As String = " ", Optional ByRef pszSubIdList As String = " ") As Long
Public Declare Function GetVisualStyles Lib "uxtheme" Alias "GetWindowTheme" (ByVal hwnd As Long) As Long
Private Type TINITCOMMONCONTROLSEX
dwSize As Long
dwICC As Long
End Type
Private Type TRELEASE
IUnk As IUnknown
VTable(0 To 2) As Long
VTableHeaderPointer As Long
End Type
Private Type TRACKMOUSEEVENTSTRUCT
cbSize As Long
dwFlags As Long
hWndTrack As Long
dwHoverTime As Long
End Type
Private Enum UxThemeButtonParts
BP_PUSHBUTTON = 1
BP_RADIOBUTTON = 2
BP_CHECKBOX = 3
BP_GROUPBOX = 4
BP_USERBUTTON = 5
End Enum
Private Enum UxThemeButtonStates
PBS_NORMAL = 1
PBS_HOT = 2
PBS_PRESSED = 3
PBS_DISABLED = 4
PBS_DEFAULTED = 5
End Enum
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type PAINTSTRUCT
hDC As Long
fErase As Long
RCPaint As RECT
fRestore As Long
fIncUpdate As Long
RGBReserved(0 To 31) As Byte
End Type
Private Type DLLVERSIONINFO
cbSize As Long
dwMajor As Long
dwMinor As Long
dwBuildNumber As Long
dwPlatformID As Long
End Type
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function InitCommonControlsEx Lib "comctl32" (ByRef ICCEX As TINITCOMMONCONTROLSEX) As Long
Private Declare Function SetErrorMode Lib "kernel32" (ByVal wMode As Long) As Long
Private Declare Function DllGetVersion Lib "comctl32" (ByRef pdvi As DLLVERSIONINFO) As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function ExtSelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long, ByVal fnMode As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DrawState Lib "user32" Alias "DrawStateW" (ByVal hDC As Long, ByVal hBrush As Long, ByVal lpDrawStateProc As Long, ByVal lData As Long, ByVal wData As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal fFlags As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropW" (ByVal hwnd As Long, ByVal lpString As Long) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropW" (ByVal hwnd As Long, ByVal lpString As Long, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropW" (ByVal hwnd As Long, ByVal lpString As Long) As Long
Private Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, ByRef lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, ByRef lpPaint As PAINTSTRUCT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As Any, ByVal bErase As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hDC As Long, ByRef lpRect As RECT) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextW" (ByVal hDC As Long, ByVal lpStr As Long, ByVal nCount As Long, ByRef lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function TrackMouseEvent Lib "user32" (ByRef lpEventTrack As TRACKMOUSEEVENTSTRUCT) As Long
Private Declare Function TransparentBlt Lib "msimg32" (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 nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal crTransparent As Long) As Long
Private Declare Function IsThemeBackgroundPartiallyTransparent Lib "uxtheme" (ByVal Theme As Long, iPartId As Long, iStateId As Long) As Long
Private Declare Function DrawThemeParentBackground Lib "uxtheme" (ByVal hwnd As Long, ByVal hDC As Long, ByRef pRect As RECT) As Long
Private Declare Function DrawThemeBackground Lib "uxtheme" (ByVal Theme As Long, ByVal hDC As Long, ByVal iPartId As Long, ByVal iStateId As Long, ByRef pRect As RECT, ByRef pClipRect As RECT) As Long
Private Declare Function DrawThemeText Lib "uxtheme" (ByVal Theme As Long, ByVal hDC As Long, ByVal iPartId As Long, ByVal iStateId As Long, ByVal pszText As Long, ByVal iCharCount As Long, ByVal dwTextFlags As Long, ByVal dwTextFlags2 As Long, ByRef pRect As RECT) As Long
Private Declare Function GetThemeBackgroundRegion Lib "uxtheme" (ByVal Theme As Long, ByVal hDC As Long, ByVal iPartId As Long, ByVal iStateId As Long, ByRef pRect As RECT, ByRef hRgn As Long) As Long
Private Declare Function GetThemeBackgroundContentRect Lib "uxtheme" (ByVal Theme As Long, ByVal hDC As Long, ByVal iPartId As Long, ByVal iStateId As Long, ByRef pBoundingRect As RECT, ByRef pContentRect As RECT) As Long
Private Declare Function OpenThemeData Lib "uxtheme" (ByVal hwnd As Long, ByVal pszClassList As Long) As Long
Private Declare Function CloseThemeData Lib "uxtheme" (ByVal Theme As Long) As Long
Private Declare Function IsAppThemed Lib "uxtheme" () As Long
Private Declare Function IsThemeActive Lib "uxtheme" () As Long
Private Declare Function GetThemeAppProperties Lib "uxtheme" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function SetWindowSubclass Lib "comctl32" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32" (ByVal hwnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function DefSubclassProc Lib "comctl32" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const ICC_STANDARD_CLASSES As Long = &H4000
Private Const STAP_ALLOW_CONTROLS As Long = (1 * (2 ^ 1))
Private Const S_OK As Long = &H0
Private Const UIS_CLEAR As Long = 2
Private Const UISF_HIDEFOCUS As Long = &H1
Private Const UISF_HIDEACCEL As Long = &H2
Private Const WM_UPDATEUISTATE As Long = &H128
Private Const WM_QUERYUISTATE As Long = &H129
Private Const WM_SETFOCUS As Long = &H7
Private Const WM_KILLFOCUS As Long = &H8
Private Const WM_ENABLE As Long = &HA
Private Const WM_SETREDRAW As Long = &HB
Private Const WM_PAINT As Long = &HF
Private Const WM_NCPAINT As Long = &H85
Private Const WM_NCDESTROY As Long = &H82
Private Const BM_GETSTATE As Long = &HF2
Private Const WM_MOUSEMOVE As Long = &H200
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const WM_LBUTTONUP As Long = &H202
Private Const WM_RBUTTONUP As Long = &H205
Private Const WM_MOUSELEAVE As Long = &H2A3
Private Const WM_PRINTCLIENT As Long = &H318
Private Const WM_THEMECHANGED As Long = &H31A
Private Const BST_PUSHED As Long = &H4
Private Const BST_FOCUS As Long = &H8
Private Const DT_CENTER As Long = &H1
Private Const DT_WORDBREAK As Long = &H10
Private Const DT_CALCRECT As Long = &H400
Private Const DT_HIDEPREFIX As Long = &H100000
Private Const TME_LEAVE As Long = 2
Private Const RGN_DIFF As Long = 4
Private Const RGN_COPY As Long = 5
Private Const DST_ICON As Long = &H3
Private Const DST_BITMAP As Long = &H4
Private Const DSS_DISABLED As Long = &H20
Public Sub InitVisualStyles()
If App.LogMode <> 0 Then Call InitReleaseVisualStyles(AddressOf ReleaseVisualStyles)
Dim ICCEX As TINITCOMMONCONTROLSEX
With ICCEX
.dwSize = LenB(ICCEX)
.dwICC = ICC_STANDARD_CLASSES
End With
InitCommonControlsEx ICCEX
End Sub
Private Sub InitReleaseVisualStyles(ByVal Address As Long)
Static Release As TRELEASE
If Release.VTableHeaderPointer <> 0 Then Exit Sub
If GetComCtlVersion >= 6 Then
Release.VTable(2) = Address
Release.VTableHeaderPointer = VarPtr(Release.VTable(0))
CopyMemory Release.IUnk, VarPtr(Release.VTableHeaderPointer), 4
End If
End Sub
Private Function ReleaseVisualStyles() As Long
Const SEM_NOGPFAULTERRORBOX As Long = &H2
SetErrorMode SEM_NOGPFAULTERRORBOX
End Function
Public Sub SetupVisualStyles(ByVal Form As VB.Form)
If GetComCtlVersion() >= 6 Then SendMessage Form.hwnd, WM_UPDATEUISTATE, MakeDWord(UIS_CLEAR, UISF_HIDEFOCUS Or UISF_HIDEACCEL), ByVal 0&
If EnabledVisualStyles() = False Then Exit Sub
Dim CurrControl As VB.Control
For Each CurrControl In Form.Controls
Select Case TypeName(CurrControl)
Case "Frame"
SetWindowSubclass CurrControl.hwnd, AddressOf RedirectFrame, ObjPtr(CurrControl), 0
Case "CommandButton", "OptionButton", "CheckBox"
If CurrControl.Style = vbButtonGraphical Then
SetProp CurrControl.hwnd, StrPtr("VisualStyles"), GetVisualStyles(CurrControl.hwnd)
If CurrControl.Enabled = True Then SetProp CurrControl.hwnd, StrPtr("Enabled"), 1
SetWindowSubclass CurrControl.hwnd, AddressOf RedirectButton, ObjPtr(CurrControl), ObjPtr(CurrControl)
End If
End Select
Next CurrControl
End Sub
Public Function EnabledVisualStyles() As Boolean
If GetComCtlVersion() >= 6 Then
If IsThemeActive() <> 0 Then
If IsAppThemed() <> 0 Then
EnabledVisualStyles = True
ElseIf (GetThemeAppProperties() And STAP_ALLOW_CONTROLS) <> 0 Then
EnabledVisualStyles = True
End If
End If
End If
End Function
Public Function GetComCtlVersion() As Long
Static Done As Boolean, Value As Long
If Done = False Then
Dim Version As DLLVERSIONINFO
On Error Resume Next
Version.cbSize = LenB(Version)
If DllGetVersion(Version) = S_OK Then Value = Version.dwMajor
Done = True
End If
GetComCtlVersion = Value
End Function
Private Function RedirectFrame(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Select Case wMsg
Case WM_PRINTCLIENT, WM_MOUSELEAVE
RedirectFrame = DefWindowProc(hwnd, wMsg, wParam, lParam)
Exit Function
End Select
RedirectFrame = DefSubclassProc(hwnd, wMsg, wParam, lParam)
If wMsg = WM_NCDESTROY Then Call RemoveRedirectFrame(hwnd, uIdSubclass)
End Function
Private Sub RemoveRedirectFrame(ByVal hwnd As Long, ByVal uIdSubclass As Long)
RemoveWindowSubclass hwnd, AddressOf RedirectFrame, uIdSubclass
End Sub
Private Function RedirectButton(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal Button As Object) As Long
Dim SetRedraw As Boolean
Select Case wMsg
Case WM_NCPAINT
Exit Function
Case WM_PAINT
If IsWindowVisible(hwnd) <> 0 And GetProp(hwnd, StrPtr("VisualStyles")) <> 0 Then
Dim PS As PAINTSTRUCT
SetProp hwnd, StrPtr("Painted"), 1
Call DrawButton(hwnd, BeginPaint(hwnd, PS), Button)
EndPaint hwnd, PS
Exit Function
End If
Case WM_SETFOCUS, WM_ENABLE
If IsWindowVisible(hwnd) <> 0 Then
SetRedraw = True
SendMessage hwnd, WM_SETREDRAW, 0, ByVal 0&
End If
End Select
RedirectButton = DefSubclassProc(hwnd, wMsg, wParam, lParam)
If wMsg = WM_NCDESTROY Then
Call RemoveRedirectButton(hwnd, uIdSubclass)
RemoveProp hwnd, StrPtr("VisualStyles")
RemoveProp hwnd, StrPtr("Enabled")
RemoveProp hwnd, StrPtr("Hot")
RemoveProp hwnd, StrPtr("Painted")
RemoveProp hwnd, StrPtr("ButtonPart")
ElseIf IsWindow(hwnd) <> 0 Then
Select Case wMsg
Case WM_THEMECHANGED
SetProp hwnd, StrPtr("VisualStyles"), GetVisualStyles(hwnd)
Button.Refresh
Case WM_MOUSELEAVE
SetProp hwnd, StrPtr("Hot"), 0
Button.Refresh
Case WM_MOUSEMOVE
If GetProp(hwnd, StrPtr("Hot")) = 0 Then
SetProp hwnd, StrPtr("Hot"), 1
InvalidateRect hwnd, ByVal 0&, 0
Dim TME As TRACKMOUSEEVENTSTRUCT
With TME
.cbSize = LenB(TME)
.hWndTrack = hwnd
.dwFlags = TME_LEAVE
End With
TrackMouseEvent TME
ElseIf GetProp(hwnd, StrPtr("Painted")) = 0 Then
Button.Refresh
End If
Case WM_SETFOCUS, WM_ENABLE
If SetRedraw = True Then
SendMessage hwnd, WM_SETREDRAW, 1, ByVal 0&
If wMsg = WM_ENABLE Then
SetProp hwnd, StrPtr("Enabled"), 0
InvalidateRect hwnd, ByVal 0&, 0
Else
SetProp hwnd, StrPtr("Enabled"), 1
Button.Refresh
End If
End If
Case WM_LBUTTONDOWN, WM_LBUTTONUP, WM_RBUTTONUP
Button.Refresh
End Select
End If
End Function
Private Sub RemoveRedirectButton(ByVal hwnd As Long, ByVal uIdSubclass As Long)
RemoveWindowSubclass hwnd, AddressOf RedirectButton, uIdSubclass
End Sub
Private Sub DrawButton(ByVal hwnd As Long, ByVal hDC As Long, ByVal Button As Object)
Dim Theme As Long, ButtonPart As Long, ButtonState As Long, UIState As Long
Dim Enabled As Boolean, Checked As Boolean, Default As Boolean, Hot As Boolean, Pushed As Boolean, Focused As Boolean
Dim hFontOld As Long, ButtonFont As IFont
Dim ButtonPicture As IPictureDisp, DisabledPictureAvailable As Boolean
Dim ClientRect As RECT, TextRect As RECT, RgnClip As Long
Dim cx As Long, cy As Long, X As Long, Y As Long
ButtonPart = GetProp(hwnd, StrPtr("ButtonPart"))
If ButtonPart = 0 Then
Select Case TypeName(Button)
Case "CommandButton"
ButtonPart = BP_PUSHBUTTON
Case "OptionButton"
ButtonPart = BP_RADIOBUTTON
Case "CheckBox"
ButtonPart = BP_CHECKBOX
End Select
If ButtonPart <> 0 Then SetProp hwnd, StrPtr("ButtonPart"), ButtonPart
End If
Select Case ButtonPart
Case BP_PUSHBUTTON
Default = Button.Default
If GetFocus() <> hwnd Then
On Error Resume Next
If CLng(Button.Parent.ActiveControl.Default) > 0 Then Else Default = False
On Error GoTo 0
End If
Case BP_RADIOBUTTON
Checked = Button.Value
Default = False
Case BP_CHECKBOX
Checked = IIf(Button.Value = vbChecked, True, False)
Default = False
End Select
ButtonPart = BP_PUSHBUTTON
ButtonState = SendMessage(hwnd, BM_GETSTATE, 0, ByVal 0&)
UIState = SendMessage(hwnd, WM_QUERYUISTATE, 0, ByVal 0&)
Enabled = IIf(GetProp(hwnd, StrPtr("Enabled")) = 1, True, Button.Enabled)
Hot = IIf(GetProp(hwnd, StrPtr("Hot")) = 0, False, True)
If Checked = True Then Hot = False
Pushed = IIf((ButtonState And BST_PUSHED) = 0, False, True)
Focused = IIf((ButtonState And BST_FOCUS) = 0, False, True)
If Enabled = False Then
ButtonState = PBS_DISABLED
Set ButtonPicture = CoalescePicture(Button.DisabledPicture, Button.Picture)
If Not Button.DisabledPicture Is Nothing Then
If Button.DisabledPicture.Handle <> 0 Then DisabledPictureAvailable = True
End If
ElseIf Hot = True And Pushed = False Then
ButtonState = PBS_HOT
If Checked = True Then
Set ButtonPicture = CoalescePicture(Button.DownPicture, Button.Picture)
Else
Set ButtonPicture = Button.Picture
End If
ElseIf Checked = True Or Pushed = True Then
ButtonState = PBS_PRESSED
Set ButtonPicture = CoalescePicture(Button.DownPicture, Button.Picture)
ElseIf Focused = True Or Default = True Then
ButtonState = PBS_DEFAULTED
Set ButtonPicture = Button.Picture
Else
ButtonState = PBS_NORMAL
Set ButtonPicture = Button.Picture
End If
If Not ButtonPicture Is Nothing Then
If ButtonPicture.Handle = 0 Then Set ButtonPicture = Nothing
End If
GetClientRect hwnd, ClientRect
Theme = OpenThemeData(hwnd, StrPtr("Button"))
If Theme <> 0 Then
GetThemeBackgroundRegion Theme, hDC, ButtonPart, ButtonState, ClientRect, RgnClip
ExtSelectClipRgn hDC, RgnClip, RGN_DIFF
Dim Brush As Long
Brush = CreateSolidBrush(WinColor(Button.BackColor))
FillRect hDC, ClientRect, Brush
DeleteObject Brush
If IsThemeBackgroundPartiallyTransparent(Theme, ButtonPart, ButtonState) <> 0 Then DrawThemeParentBackground hwnd, hDC, ClientRect
ExtSelectClipRgn hDC, 0, RGN_COPY
DeleteObject RgnClip
DrawThemeBackground Theme, hDC, ButtonPart, ButtonState, ClientRect, ClientRect
GetThemeBackgroundContentRect Theme, hDC, ButtonPart, ButtonState, ClientRect, ClientRect
If Focused = True Then
If Not (UIState And UISF_HIDEFOCUS) = UISF_HIDEFOCUS Then DrawFocusRect hDC, ClientRect
End If
If Not Button.Caption = vbNullString Then
Set ButtonFont = Button.Font
hFontOld = SelectObject(hDC, ButtonFont.hFont)
LSet TextRect = ClientRect
DrawText hDC, StrPtr(Button.Caption), -1, TextRect, DT_CALCRECT Or DT_WORDBREAK Or CLng(IIf((UIState And UISF_HIDEACCEL) = UISF_HIDEACCEL, DT_HIDEPREFIX, 0))
TextRect.Left = ClientRect.Left
TextRect.Right = ClientRect.Right
If ButtonPicture Is Nothing Then
TextRect.Top = ((ClientRect.Bottom - TextRect.Bottom) / 2) + (3 * PixelsPerDIP_Y())
TextRect.Bottom = TextRect.Top + TextRect.Bottom
Else
TextRect.Top = (ClientRect.Bottom - TextRect.Bottom) + (1 * PixelsPerDIP_Y())
TextRect.Bottom = ClientRect.Bottom
End If
DrawThemeText Theme, hDC, ButtonPart, ButtonState, StrPtr(Button.Caption), -1, DT_CENTER Or DT_WORDBREAK Or CLng(IIf((UIState And UISF_HIDEACCEL) = UISF_HIDEACCEL, DT_HIDEPREFIX, 0)), 0, TextRect
SelectObject hDC, hFontOld
ClientRect.Bottom = TextRect.Top
ClientRect.Left = TextRect.Left
End If
CloseThemeData Theme
End If
If Not ButtonPicture Is Nothing Then
cx = CHimetricToPixel_X(ButtonPicture.Width)
cy = CHimetricToPixel_Y(ButtonPicture.Height)
X = ClientRect.Left + ((ClientRect.Right - ClientRect.Left - cx) / 2)
Y = ClientRect.Top + ((ClientRect.Bottom - ClientRect.Top - cy) / 2)
If Enabled = True Or DisabledPictureAvailable = True Then
If ButtonPicture.Type = vbPicTypeBitmap And Button.UseMaskColor = True Then
Dim hDCScreen As Long
Dim hDC1 As Long, hBmpOld1 As Long
hDCScreen = GetDC(0)
If hDCScreen <> 0 Then
hDC1 = CreateCompatibleDC(hDCScreen)
If hDC1 <> 0 Then
hBmpOld1 = SelectObject(hDC1, ButtonPicture.Handle)
TransparentBlt hDC, X, Y, cx, cy, hDC1, 0, 0, cx, cy, WinColor(Button.MaskColor)
SelectObject hDC1, hBmpOld1
DeleteDC hDC1
End If
ReleaseDC 0, hDCScreen
End If
Else
With ButtonPicture
.Render hDC Or 0&, X Or 0&, Y Or 0&, cx Or 0&, cy Or 0&, 0&, .Height, .Width, -.Height, ByVal 0&
End With
End If
Else
If ButtonPicture.Type = vbPicTypeIcon Then
DrawState hDC, 0, 0, ButtonPicture.Handle, 0, X, Y, cx, cy, DST_ICON Or DSS_DISABLED
Else
Dim hImage As Long
hImage = BitmapHandleFromPicture(ButtonPicture, vbWhite)
' The DrawState API with DSS_DISABLED will draw white as transparent.
' This will ensure GIF bitmaps or metafiles are better drawn.
DrawState hDC, 0, 0, hImage, 0, X, Y, cx, cy, DST_BITMAP Or DSS_DISABLED
DeleteObject hImage
End If
End If
End If
End Sub
Private Function CoalescePicture(ByVal Picture As IPictureDisp, ByVal DefaultPicture As IPictureDisp) As IPictureDisp
If Picture Is Nothing Then
Set CoalescePicture = DefaultPicture
ElseIf Picture.Handle = 0 Then
Set CoalescePicture = DefaultPicture
Else
Set CoalescePicture = Picture
End If
End Function

复制代码

VTableHandle.bas

Option Explicit
' Required:
' OLEGuids.tlb (in IDE only)
#If False Then
Private VTableInterfaceControl, VTableInterfaceInPlaceActiveObject, VTableInterfacePerPropertyBrowsing
#End If
Public Enum VTableInterfaceConstants
VTableInterfaceControl = 1
VTableInterfaceInPlaceActiveObject = 2
VTableInterfacePerPropertyBrowsing = 3
End Enum
Private Type VTableIPAODataStruct
VTable As Long
RefCount As Long
OriginalIOleIPAO As OLEGuids.IOleInPlaceActiveObject
IOleIPAO As OLEGuids.IOleInPlaceActiveObjectVB
End Type
Private Enum VTableIndexControlConstants
' Ignore : ControlQueryInterface = 1
' Ignore : ControlAddRef = 2
' Ignore : ControlRelease = 3
VTableIndexControlGetControlInfo = 4
VTableIndexControlOnMnemonic = 5
' Ignore : ControlOnAmbientPropertyChange = 6
' Ignore : ControlFreezeEvents = 7
End Enum
Private Enum VTableIndexPPBConstants
' Ignore : PPBQueryInterface = 1
' Ignore : PPBAddRef = 2
' Ignore : PPBRelease = 3
VTableIndexPPBGetDisplayString = 4
' Ignore : PPBMapPropertyToPage = 5
VTAbleIndexPPBGetPredefinedStrings = 6
VTAbleIndexPPBGetPredefinedValue = 7
End Enum
Private Type VTableIEnumVARIANTDataStruct
VTable As Long
RefCount As Long
Enumerable As Object
Index As Long
Count As Long
End Type
Public Const CTRLINFO_EATS_RETURN As Long = 1
Public Const CTRLINFO_EATS_ESCAPE As Long = 2
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal hMem As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
Private Declare Function EnumThreadWindows Lib "user32" (ByVal dwThreadID As Long, ByVal lpfn As Long, ByVal lParam As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropW" (ByVal hwnd As Long, ByVal lpString As Long, ByVal hData As Long) As Long
Private Declare Function GetProp Lib "user32" Alias "GetPropW" (ByVal hwnd As Long, ByVal lpString As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropW" (ByVal hwnd As Long, ByVal lpString As Long) As Long
Private Declare Function GetAncestor Lib "user32" (ByVal hwnd As Long, ByVal gaFlags As Long) As Long
Private Declare Function CoTaskMemAlloc Lib "ole32" (ByVal cBytes As Long) As Long
Private Declare Function SysAllocString Lib "oleaut32" (ByVal lpString As Long) As Long
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal lpvInstance As Long, ByVal oVft As Long, ByVal CallConv As Long, ByVal vtReturn As Integer, ByVal cActuals As Long, ByVal prgvt As Long, ByVal prgpvarg As Long, ByRef pvargResult As Variant) As Long
Private Declare Function VariantCopyToPtr Lib "oleaut32" Alias "VariantCopy" (ByVal pvargDest As Long, ByRef pvargSrc As Variant) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszProgID As Long, ByRef pCLSID As Any) As Long
Private Const CC_STDCALL As Long = 4
Private Const GA_ROOT As Long = 2
Private Const GWL_HWNDPARENT As Long = (-8)
Private Const E_OUTOFMEMORY As Long = &H8007000E
Private Const E_INVALIDARG As Long = &H80070057
Private Const E_NOTIMPL As Long = &H80004001
Private Const E_NOINTERFACE As Long = &H80004002
Private Const E_POINTER As Long = &H80004003
Private Const S_FALSE As Long = &H1
Private Const S_OK As Long = &H0
Private VTableIPAO(0 To 9) As Long, VTableIPAOData As VTableIPAODataStruct
Private VTableSubclassControl As VTableSubclass
Private VTableSubclassPPB As VTableSubclass, StringsOutArray() As String, CookiesOutArray() As Long
Private VTableIEnumVARIANT(0 To 6) As Long
Public Sub SetVTableSubclass(ByVal This As Object, ByVal OLEInterface As VTableInterfaceConstants)
Select Case OLEInterface
Case VTableInterfaceInPlaceActiveObject
If VTableSubclassSupported(This, VTableInterfaceInPlaceActiveObject) = True Then VTableIPAOData.RefCount = VTableIPAOData.RefCount + 1
Case VTableInterfaceControl
If VTableSubclassSupported(This, VTableInterfaceControl) = True Then Call ReplaceIOleControl(This)
Case VTableInterfacePerPropertyBrowsing
If VTableSubclassSupported(This, VTableInterfacePerPropertyBrowsing) = True Then Call ReplaceIPPB(This)
End Select
End Sub
Public Sub RemoveVTableSubclass(ByVal This As Object, ByVal OLEInterface As VTableInterfaceConstants)
Select Case OLEInterface
Case VTableInterfaceInPlaceActiveObject
If VTableSubclassSupported(This, VTableInterfaceInPlaceActiveObject) = True Then VTableIPAOData.RefCount = VTableIPAOData.RefCount - 1
Case VTableInterfaceControl
If VTableSubclassSupported(This, VTableInterfaceControl) = True Then Call RestoreIOleControl(This)
Case VTableInterfacePerPropertyBrowsing
If VTableSubclassSupported(This, VTableInterfacePerPropertyBrowsing) = True Then Call RestoreIPPB(This)
End Select
End Sub
Public Sub RemoveAllVTableSubclass(ByVal OLEInterface As VTableInterfaceConstants)
Select Case OLEInterface
Case VTableInterfaceInPlaceActiveObject
VTableIPAOData.RefCount = 0
If Not VTableIPAOData.OriginalIOleIPAO Is Nothing Then Call ActivateIPAO(VTableIPAOData.OriginalIOleIPAO)
Case VTableInterfaceControl
Set VTableSubclassControl = Nothing
Case VTableInterfacePerPropertyBrowsing
Set VTableSubclassPPB = Nothing
End Select
End Sub
Private Function VTableSubclassSupported(ByRef This As Object, ByVal OLEInterface As VTableInterfaceConstants) As Boolean
On Error GoTo CATCH_EXCEPTION
Select Case OLEInterface
Case VTableInterfaceInPlaceActiveObject
Dim ShadowIOleIPAO As OLEGuids.IOleInPlaceActiveObject
Dim ShadowIOleInPlaceActiveObjectVB As OLEGuids.IOleInPlaceActiveObjectVB
Set ShadowIOleIPAO = This
Set ShadowIOleInPlaceActiveObjectVB = This
VTableSubclassSupported = Not CBool(ShadowIOleIPAO Is Nothing Or ShadowIOleInPlaceActiveObjectVB Is Nothing)
Case VTableInterfaceControl
Dim ShadowIOleControl As OLEGuids.IOleControl
Dim ShadowIOleControlVB As OLEGuids.IOleControlVB
Set ShadowIOleControl = This
Set ShadowIOleControlVB = This
VTableSubclassSupported = Not CBool(ShadowIOleControl Is Nothing Or ShadowIOleControlVB Is Nothing)
Case VTableInterfacePerPropertyBrowsing
Dim ShadowIPPB As OLEGuids.IPerPropertyBrowsing
Dim ShadowIPerPropertyBrowsingVB As OLEGuids.IPerPropertyBrowsingVB
Set ShadowIPPB = This
Set ShadowIPerPropertyBrowsingVB = This
VTableSubclassSupported = Not CBool(ShadowIPPB Is Nothing Or ShadowIPerPropertyBrowsingVB Is Nothing)
End Select
CATCH_EXCEPTION:
End Function
Public Function VTableCall(ByVal RetType As VbVarType, ByVal InterfacePointer As Long, ByVal Entry As Long, ParamArray ArgList() As Variant) As Variant
Debug.Assert Not (Entry < 1 Or InterfacePointer = 0)
Dim VarArgList As Variant, HResult As Long
VarArgList = ArgList
If UBound(VarArgList) > -1 Then
Dim i As Long, ArrVarType() As Integer, ArrVarPtr() As Long
ReDim ArrVarType(LBound(VarArgList) To UBound(VarArgList)) As Integer
ReDim ArrVarPtr(LBound(VarArgList) To UBound(VarArgList)) As Long
For i = LBound(VarArgList) To UBound(VarArgList)
ArrVarType(i) = VarType(VarArgList(i))
ArrVarPtr(i) = VarPtr(VarArgList(i))
Next i
HResult = DispCallFunc(InterfacePointer, (Entry - 1) * 4, CC_STDCALL, RetType, i, VarPtr(ArrVarType(0)), VarPtr(ArrVarPtr(0)), VTableCall)
Else
HResult = DispCallFunc(InterfacePointer, (Entry - 1) * 4, CC_STDCALL, RetType, 0, 0, 0, VTableCall)
End If
SetLastError HResult ' S_OK will clear the last error code, if any.
End Function
Public Function VTableInterfaceSupported(ByVal This As OLEGuids.IUnknownUnrestricted, ByVal IIDString As String) As Boolean
Debug.Assert Not (This Is Nothing)
Dim HResult As Long, IID As OLEGuids.OLECLSID, ObjectPointer As Long
CLSIDFromString StrPtr(IIDString), IID
HResult = This.QueryInterface(VarPtr(IID), ObjectPointer)
If ObjectPointer <> 0 Then
Dim IUnk As OLEGuids.IUnknownUnrestricted
CopyMemory IUnk, ObjectPointer, 4
IUnk.Release
CopyMemory IUnk, 0&, 4
End If
VTableInterfaceSupported = CBool(HResult = S_OK)
End Function
Public Sub SyncObjectRectsToContainer(ByVal This As Object)
On Error GoTo CATCH_EXCEPTION
Dim PropOleObject As OLEGuids.IOleObject
Dim PropOleInPlaceObject As OLEGuids.IOleInPlaceObject
Dim PropOleInPlaceSite As OLEGuids.IOleInPlaceSite
Dim PosRect As OLEGuids.OLERECT
Dim ClipRect As OLEGuids.OLERECT
Dim FrameInfo As OLEGuids.OLEINPLACEFRAMEINFO
Set PropOleObject = This
Set PropOleInPlaceObject = This
Set PropOleInPlaceSite = PropOleObject.GetClientSite
PropOleInPlaceSite.GetWindowContext Nothing, Nothing, VarPtr(PosRect), VarPtr(ClipRect), VarPtr(FrameInfo)
PropOleInPlaceObject.SetObjectRects VarPtr(PosRect), VarPtr(ClipRect)
CATCH_EXCEPTION:
End Sub
Public Sub ActivateIPAO(ByVal This As Object)
On Error GoTo CATCH_EXCEPTION
Dim PropOleObject As OLEGuids.IOleObject
Dim PropOleInPlaceSite As OLEGuids.IOleInPlaceSite
Dim PropOleInPlaceFrame As OLEGuids.IOleInPlaceFrame
Dim PropOleInPlaceUIWindow As OLEGuids.IOleInPlaceUIWindow
Dim PropOleInPlaceActiveObject As OLEGuids.IOleInPlaceActiveObject
Dim PosRect As OLEGuids.OLERECT
Dim ClipRect As OLEGuids.OLERECT
Dim FrameInfo As OLEGuids.OLEINPLACEFRAMEINFO
Set PropOleObject = This
If VTableIPAOData.RefCount > 0 Then
With VTableIPAOData
.VTable = GetVTableIPAO()
Set .OriginalIOleIPAO = This
Set .IOleIPAO = This
End With
CopyMemory ByVal VarPtr(PropOleInPlaceActiveObject), VarPtr(VTableIPAOData), 4
PropOleInPlaceActiveObject.AddRef
Else
Set PropOleInPlaceActiveObject = This
End If
Set PropOleInPlaceSite = PropOleObject.GetClientSite
PropOleInPlaceSite.GetWindowContext PropOleInPlaceFrame, PropOleInPlaceUIWindow, VarPtr(PosRect), VarPtr(ClipRect), VarPtr(FrameInfo)
PropOleInPlaceFrame.SetActiveObject PropOleInPlaceActiveObject, vbNullString
If Not PropOleInPlaceUIWindow Is Nothing Then PropOleInPlaceUIWindow.SetActiveObject PropOleInPlaceActiveObject, vbNullString
CATCH_EXCEPTION:
End Sub
Public Sub DeActivateIPAO()
On Error GoTo CATCH_EXCEPTION
If VTableIPAOData.OriginalIOleIPAO Is Nothing Then Exit Sub
Dim PropOleObject As OLEGuids.IOleObject
Dim PropOleInPlaceSite As OLEGuids.IOleInPlaceSite
Dim PropOleInPlaceFrame As OLEGuids.IOleInPlaceFrame
Dim PropOleInPlaceUIWindow As OLEGuids.IOleInPlaceUIWindow
Dim PosRect As OLEGuids.OLERECT
Dim ClipRect As OLEGuids.OLERECT
Dim FrameInfo As OLEGuids.OLEINPLACEFRAMEINFO
Set PropOleObject = VTableIPAOData.OriginalIOleIPAO
Set PropOleInPlaceSite = PropOleObject.GetClientSite
PropOleInPlaceSite.GetWindowContext PropOleInPlaceFrame, PropOleInPlaceUIWindow, VarPtr(PosRect), VarPtr(ClipRect), VarPtr(FrameInfo)
PropOleInPlaceFrame.SetActiveObject Nothing, vbNullString
If Not PropOleInPlaceUIWindow Is Nothing Then PropOleInPlaceUIWindow.SetActiveObject Nothing, vbNullString
CATCH_EXCEPTION:
Set VTableIPAOData.OriginalIOleIPAO = Nothing
Set VTableIPAOData.IOleIPAO = Nothing
End Sub
Private Function GetVTableIPAO() As Long
If VTableIPAO(0) = 0 Then
VTableIPAO(0) = ProcPtr(AddressOf IOleIPAO_QueryInterface)
VTableIPAO(1) = ProcPtr(AddressOf IOleIPAO_AddRef)
VTableIPAO(2) = ProcPtr(AddressOf IOleIPAO_Release)
VTableIPAO(3) = ProcPtr(AddressOf IOleIPAO_GetWindow)
VTableIPAO(4) = ProcPtr(AddressOf IOleIPAO_ContextSensitiveHelp)
VTableIPAO(5) = ProcPtr(AddressOf IOleIPAO_TranslateAccelerator)
VTableIPAO(6) = ProcPtr(AddressOf IOleIPAO_OnFrameWindowActivate)
VTableIPAO(7) = ProcPtr(AddressOf IOleIPAO_OnDocWindowActivate)
VTableIPAO(8) = ProcPtr(AddressOf IOleIPAO_ResizeBorder)
VTableIPAO(9) = ProcPtr(AddressOf IOleIPAO_EnableModeless)
End If
GetVTableIPAO = VarPtr(VTableIPAO(0))
End Function
Private Function IOleIPAO_QueryInterface(ByRef This As VTableIPAODataStruct, ByRef IID As OLEGuids.OLECLSID, ByRef pvObj As Long) As Long
If VarPtr(pvObj) = 0 Then
IOleIPAO_QueryInterface = E_POINTER
Exit Function
End If
' IID_IOleInPlaceActiveObject = {00000117-0000-0000-C000-000000000046}
If IID.Data1 = &H117 And IID.Data2 = &H0 And IID.Data3 = &H0 Then
If IID.Data4(0) = &HC0 And IID.Data4(1) = &H0 And IID.Data4(2) = &H0 And IID.Data4(3) = &H0 _
And IID.Data4(4) = &H0 And IID.Data4(5) = &H0 And IID.Data4(6) = &H0 And IID.Data4(7) = &H46 Then
pvObj = VarPtr(This)
IOleIPAO_AddRef This
IOleIPAO_QueryInterface = S_OK
Else
IOleIPAO_QueryInterface = This.OriginalIOleIPAO.QueryInterface(VarPtr(IID), pvObj)
End If
Else
IOleIPAO_QueryInterface = This.OriginalIOleIPAO.QueryInterface(VarPtr(IID), pvObj)
End If
End Function
Private Function IOleIPAO_AddRef(ByRef This As VTableIPAODataStruct) As Long
IOleIPAO_AddRef = This.OriginalIOleIPAO.AddRef
End Function
Private Function IOleIPAO_Release(ByRef This As VTableIPAODataStruct) As Long
IOleIPAO_Release = This.OriginalIOleIPAO.Release
End Function
Private Function IOleIPAO_GetWindow(ByRef This As VTableIPAODataStruct, ByRef hwnd As Long) As Long
IOleIPAO_GetWindow = This.OriginalIOleIPAO.GetWindow(hwnd)
End Function
Private Function IOleIPAO_ContextSensitiveHelp(ByRef This As VTableIPAODataStruct, ByVal EnterMode As Long) As Long
IOleIPAO_ContextSensitiveHelp = This.OriginalIOleIPAO.ContextSensitiveHelp(EnterMode)
End Function
Private Function IOleIPAO_TranslateAccelerator(ByRef This As VTableIPAODataStruct, ByRef Msg As OLEGuids.OLEACCELMSG) As Long
If VarPtr(Msg) = 0 Then
IOleIPAO_TranslateAccelerator = E_INVALIDARG
Exit Function
End If
On Error GoTo CATCH_EXCEPTION
Dim Handled As Boolean
IOleIPAO_TranslateAccelerator = S_OK
This.IOleIPAO.TranslateAccelerator Handled, IOleIPAO_TranslateAccelerator, Msg.Message, Msg.wParam, Msg.lParam, GetShiftStateFromMsg()
If Handled = False Then IOleIPAO_TranslateAccelerator = This.OriginalIOleIPAO.TranslateAccelerator(VarPtr(Msg))
Exit Function
CATCH_EXCEPTION:
IOleIPAO_TranslateAccelerator = This.OriginalIOleIPAO.TranslateAccelerator(VarPtr(Msg))
End Function
Private Function IOleIPAO_OnFrameWindowActivate(ByRef This As VTableIPAODataStruct, ByVal Activate As Long) As Long
IOleIPAO_OnFrameWindowActivate = This.OriginalIOleIPAO.OnFrameWindowActivate(Activate)
End Function
Private Function IOleIPAO_OnDocWindowActivate(ByRef This As VTableIPAODataStruct, ByVal Activate As Long) As Long
IOleIPAO_OnDocWindowActivate = This.OriginalIOleIPAO.OnDocWindowActivate(Activate)
End Function
Private Function IOleIPAO_ResizeBorder(ByRef This As VTableIPAODataStruct, ByRef RC As OLEGuids.OLERECT, ByVal UIWindow As OLEGuids.IOleInPlaceUIWindow, ByVal FrameWindow As Long) As Long
IOleIPAO_ResizeBorder = This.OriginalIOleIPAO.ResizeBorder(VarPtr(RC), UIWindow, FrameWindow)
End Function
Private Function IOleIPAO_EnableModeless(ByRef This As VTableIPAODataStruct, ByVal Enable As Long) As Long
IOleIPAO_EnableModeless = This.OriginalIOleIPAO.EnableModeless(Enable)
End Function
Private Sub ReplaceIOleControl(ByVal This As OLEGuids.IOleControl)
If VTableSubclassControl Is Nothing Then Set VTableSubclassControl = New VTableSubclass
If VTableSubclassControl.RefCount = 0 Then
Dim hMain As Long, Handled As Boolean
hMain = GetHiddenMainWindow()
If hMain <> 0 Then Handled = CBool(GetProp(hMain, StrPtr("VTableSubclassControlInit")) <> 0)
If Handled = False Then
VTableSubclassControl.Subclass ObjPtr(This), VTableIndexControlGetControlInfo, VTableIndexControlOnMnemonic, _
AddressOf IOleControl_GetControlInfo, _
AddressOf IOleControl_OnMnemonic
If hMain <> 0 Then SetProp hMain, StrPtr("VTableSubclassControlInit"), 1
End If
End If
VTableSubclassControl.AddRef
End Sub
Private Sub RestoreIOleControl(ByVal This As OLEGuids.IOleControl)
If Not VTableSubclassControl Is Nothing Then
VTableSubclassControl.Release
If VTableSubclassControl.RefCount = 0 Then
Dim hMain As Long
hMain = GetHiddenMainWindow()
If hMain <> 0 Then RemoveProp hMain, StrPtr("VTableSubclassControlInit")
VTableSubclassControl.UnSubclass
End If
End If
End Sub
Public Sub OnControlInfoChanged(ByVal This As Object, Optional ByVal OnFocus As Boolean)
On Error GoTo CATCH_EXCEPTION
Dim PropOleObject As OLEGuids.IOleObject
Dim PropOleControlSite As OLEGuids.IOleControlSite
Set PropOleObject = This
Set PropOleControlSite = PropOleObject.GetClientSite
PropOleControlSite.OnControlInfoChanged
If OnFocus = True Then PropOleControlSite.OnFocus 1
CATCH_EXCEPTION:
End Sub
Private Function IOleControl_GetControlInfo(ByVal This As Object, ByRef CI As OLEGuids.OLECONTROLINFO) As Long
If VarPtr(CI) = 0 Then
IOleControl_GetControlInfo = E_POINTER
Exit Function
End If
On Error GoTo CATCH_EXCEPTION
Dim ShadowIOleControlVB As OLEGuids.IOleControlVB, Handled As Boolean
Set ShadowIOleControlVB = This
CI.cb = LenB(CI)
ShadowIOleControlVB.GetControlInfo Handled, CI.cAccel, CI.hAccel, CI.dwFlags
If Handled = False Then
IOleControl_GetControlInfo = Original_IOleControl_GetControlInfo(This, CI)
Else
If CI.cAccel > 0 And CI.hAccel = 0 Then
IOleControl_GetControlInfo = E_OUTOFMEMORY
Else
IOleControl_GetControlInfo = S_OK
End If
End If
Exit Function
CATCH_EXCEPTION:
IOleControl_GetControlInfo = Original_IOleControl_GetControlInfo(This, CI)
End Function
Private Function IOleControl_OnMnemonic(ByVal This As Object, ByRef Msg As OLEGuids.OLEACCELMSG) As Long
If VarPtr(Msg) = 0 Then
IOleControl_OnMnemonic = E_INVALIDARG
Exit Function
End If
On Error GoTo CATCH_EXCEPTION
Dim ShadowIOleControlVB As OLEGuids.IOleControlVB, Handled As Boolean
Set ShadowIOleControlVB = This
ShadowIOleControlVB.OnMnemonic Handled, Msg.Message, Msg.wParam, Msg.lParam, GetShiftStateFromMsg()
If Handled = False Then
IOleControl_OnMnemonic = Original_IOleControl_OnMnemonic(This, Msg)
Else
IOleControl_OnMnemonic = S_OK
End If
Exit Function
CATCH_EXCEPTION:
IOleControl_OnMnemonic = Original_IOleControl_OnMnemonic(This, Msg)
End Function
Private Function Original_IOleControl_GetControlInfo(ByVal This As OLEGuids.IOleControl, ByRef CI As OLEGuids.OLECONTROLINFO) As Long
VTableSubclassControl.SubclassEntry(VTableIndexControlGetControlInfo) = False
Original_IOleControl_GetControlInfo = This.GetControlInfo(CI)
VTableSubclassControl.SubclassEntry(VTableIndexControlGetControlInfo) = True
End Function
Private Function Original_IOleControl_OnMnemonic(ByVal This As OLEGuids.IOleControl, ByRef Msg As OLEGuids.OLEACCELMSG) As Long
VTableSubclassControl.SubclassEntry(VTableIndexControlOnMnemonic) = False
Original_IOleControl_OnMnemonic = This.OnMnemonic(Msg)
VTableSubclassControl.SubclassEntry(VTableIndexControlOnMnemonic) = True
End Function
Private Sub ReplaceIPPB(ByVal This As OLEGuids.IPerPropertyBrowsing)
If VTableSubclassPPB Is Nothing Then Set VTableSubclassPPB = New VTableSubclass
If VTableSubclassPPB.RefCount = 0 Then
Dim hMain As Long, Handled As Boolean
hMain = GetHiddenMainWindow()
If hMain <> 0 Then Handled = CBool(GetProp(hMain, StrPtr("VTableSubclassPPBInit")) <> 0)
If Handled = False Then
VTableSubclassPPB.Subclass ObjPtr(This), VTableIndexPPBGetDisplayString, VTAbleIndexPPBGetPredefinedValue, _
AddressOf IPPB_GetDisplayString, 0, _
AddressOf IPPB_GetPredefinedStrings, _
AddressOf IPPB_GetPredefinedValue
If hMain <> 0 Then SetProp hMain, StrPtr("VTableSubclassPPBInit"), 1
End If
End If
VTableSubclassPPB.AddRef
End Sub
Private Sub RestoreIPPB(ByVal This As OLEGuids.IPerPropertyBrowsing)
If Not VTableSubclassPPB Is Nothing Then
VTableSubclassPPB.Release
If VTableSubclassPPB.RefCount = 0 Then
Dim hMain As Long
hMain = GetHiddenMainWindow()
If hMain <> 0 Then RemoveProp hMain, StrPtr("VTableSubclassPPBInit")
VTableSubclassPPB.UnSubclass
End If
End If
End Sub
Public Function GetDispID(ByVal This As Object, ByRef MethodName As String) As Long
Dim IDispatch As OLEGuids.IDispatch, IID_NULL As OLEGuids.OLECLSID
Set IDispatch = This
IDispatch.GetIDsOfNames IID_NULL, MethodName, 1, 0, GetDispID
End Function
Private Function IPPB_GetDisplayString(ByVal This As Object, ByVal DispID As Long, ByVal lpDisplayName As Long) As Long
If lpDisplayName = 0 Then
IPPB_GetDisplayString = E_POINTER
Exit Function
End If
On Error GoTo CATCH_EXCEPTION
Dim ShadowIPerPropertyBrowsingVB As OLEGuids.IPerPropertyBrowsingVB, Handled As Boolean, DisplayName As String
Set ShadowIPerPropertyBrowsingVB = This
ShadowIPerPropertyBrowsingVB.GetDisplayString Handled, DispID, DisplayName
If Handled = False Then
IPPB_GetDisplayString = E_NOTIMPL
Else
Dim lpString As Long
lpString = SysAllocString(StrPtr(DisplayName))
CopyMemory ByVal lpDisplayName, lpString, 4
End If
Exit Function
CATCH_EXCEPTION:
IPPB_GetDisplayString = E_NOTIMPL
End Function
Private Function IPPB_GetPredefinedStrings(ByVal This As Object, ByVal DispID As Long, ByRef pCaStringsOut As OLEGuids.OLECALPOLESTR, ByRef pCaCookiesOut As OLEGuids.OLECADWORD) As Long
If VarPtr(pCaStringsOut) = 0 Or VarPtr(pCaCookiesOut) = 0 Then
IPPB_GetPredefinedStrings = E_POINTER
Exit Function
End If
On Error GoTo CATCH_EXCEPTION
Dim ShadowIPerPropertyBrowsingVB As OLEGuids.IPerPropertyBrowsingVB, Handled As Boolean
ReDim StringsOutArray(0) As String
ReDim CookiesOutArray(0) As Long
Set ShadowIPerPropertyBrowsingVB = This
ShadowIPerPropertyBrowsingVB.GetPredefinedStrings Handled, DispID, StringsOutArray(), CookiesOutArray()
If Handled = False Or UBound(StringsOutArray()) = 0 Then
IPPB_GetPredefinedStrings = E_NOTIMPL
Else
Dim cElems As Long, pElems As Long, nElemCount As Long
Dim lpString As Long
cElems = UBound(StringsOutArray())
If Not UBound(CookiesOutArray()) = cElems Then ReDim Preserve CookiesOutArray(cElems) As Long
pElems = CoTaskMemAlloc(cElems * 4)
pCaStringsOut.cElems = cElems
pCaStringsOut.pElems = pElems
For nElemCount = 0 To cElems - 1
lpString = CoTaskMemAlloc(Len(StringsOutArray(nElemCount)) + 1)
CopyMemory ByVal lpString, StrPtr(StringsOutArray(nElemCount)), 4
CopyMemory ByVal UnsignedAdd(pElems, nElemCount * 4), ByVal lpString, 4
Next nElemCount
pElems = CoTaskMemAlloc(cElems * 4)
pCaCookiesOut.cElems = cElems
pCaCookiesOut.pElems = pElems
For nElemCount = 0 To cElems - 1
CopyMemory ByVal UnsignedAdd(pElems, nElemCount * 4), CookiesOutArray(nElemCount), 4
Next nElemCount
End If
Exit Function
CATCH_EXCEPTION:
IPPB_GetPredefinedStrings = E_NOTIMPL
End Function
Private Function IPPB_GetPredefinedValue(ByVal This As Object, ByVal DispID As Long, ByVal dwCookie As Long, ByRef pVarOut As Variant) As Long
If VarPtr(pVarOut) = 0 Then
IPPB_GetPredefinedValue = E_POINTER
Exit Function
End If
On Error GoTo CATCH_EXCEPTION
Dim ShadowIPerPropertyBrowsingVB As OLEGuids.IPerPropertyBrowsingVB, Handled As Boolean
Set ShadowIPerPropertyBrowsingVB = This
ShadowIPerPropertyBrowsingVB.GetPredefinedValue Handled, DispID, dwCookie, pVarOut
If Handled = False Then IPPB_GetPredefinedValue = E_NOTIMPL
Exit Function
CATCH_EXCEPTION:
IPPB_GetPredefinedValue = E_NOTIMPL
End Function
Public Function GetNewEnum(ByVal This As Object, ByVal Upper As Long, ByVal Lower As Long) As IEnumVARIANT
Dim VTableIEnumVARIANTData As VTableIEnumVARIANTDataStruct
With VTableIEnumVARIANTData
.VTable = GetVTableIEnumVARIANT()
.RefCount = 1
Set .Enumerable = This
.Index = Lower
.Count = Upper
Dim hMem As Long
hMem = CoTaskMemAlloc(LenB(VTableIEnumVARIANTData))
If hMem <> 0 Then
CopyMemory ByVal hMem, VTableIEnumVARIANTData, LenB(VTableIEnumVARIANTData)
CopyMemory ByVal VarPtr(GetNewEnum), hMem, 4
CopyMemory ByVal VarPtr(.Enumerable), 0&, 4
End If
End With
End Function
Private Function GetVTableIEnumVARIANT() As Long
If VTableIEnumVARIANT(0) = 0 Then
VTableIEnumVARIANT(0) = ProcPtr(AddressOf IEnumVARIANT_QueryInterface)
VTableIEnumVARIANT(1) = ProcPtr(AddressOf IEnumVARIANT_AddRef)
VTableIEnumVARIANT(2) = ProcPtr(AddressOf IEnumVARIANT_Release)
VTableIEnumVARIANT(3) = ProcPtr(AddressOf IEnumVARIANT_Next)
VTableIEnumVARIANT(4) = ProcPtr(AddressOf IEnumVARIANT_Skip)
VTableIEnumVARIANT(5) = ProcPtr(AddressOf IEnumVARIANT_Reset)
VTableIEnumVARIANT(6) = ProcPtr(AddressOf IEnumVARIANT_Clone)
End If
GetVTableIEnumVARIANT = VarPtr(VTableIEnumVARIANT(0))
End Function
Private Function IEnumVARIANT_QueryInterface(ByRef This As VTableIEnumVARIANTDataStruct, ByRef IID As OLEGuids.OLECLSID, ByRef pvObj As Long) As Long
If VarPtr(pvObj) = 0 Then
IEnumVARIANT_QueryInterface = E_POINTER
Exit Function
End If
' IID_IEnumVARIANT = {00020404-0000-0000-C000-000000000046}
If IID.Data1 = &H20404 And IID.Data2 = &H0 And IID.Data3 = &H0 Then
If IID.Data4(0) = &HC0 And IID.Data4(1) = &H0 And IID.Data4(2) = &H0 And IID.Data4(3) = &H0 _
And IID.Data4(4) = &H0 And IID.Data4(5) = &H0 And IID.Data4(6) = &H0 And IID.Data4(7) = &H46 Then
pvObj = VarPtr(This)
IEnumVARIANT_AddRef This
IEnumVARIANT_QueryInterface = S_OK
Else
IEnumVARIANT_QueryInterface = E_NOINTERFACE
End If
Else
IEnumVARIANT_QueryInterface = E_NOINTERFACE
End If
End Function
Private Function IEnumVARIANT_AddRef(ByRef This As VTableIEnumVARIANTDataStruct) As Long
This.RefCount = This.RefCount + 1
IEnumVARIANT_AddRef = This.RefCount
End Function
Private Function IEnumVARIANT_Release(ByRef This As VTableIEnumVARIANTDataStruct) As Long
This.RefCount = This.RefCount - 1
IEnumVARIANT_Release = This.RefCount
If IEnumVARIANT_Release = 0 Then
Set This.Enumerable = Nothing
CoTaskMemFree VarPtr(This)
End If
End Function
Private Function IEnumVARIANT_Next(ByRef This As VTableIEnumVARIANTDataStruct, ByVal VntCount As Long, ByVal VntArrPtr As Long, ByRef pcvFetched As Long) As Long
If VntArrPtr = 0 Then
IEnumVARIANT_Next = E_INVALIDARG
Exit Function
End If
On Error GoTo CATCH_EXCEPTION
Const VARIANT_CB As Long = 16
Dim Fetched As Long
With This
Do Until .Index > .Count
VariantCopyToPtr VntArrPtr, .Enumerable(.Index)
.Index = .Index + 1
Fetched = Fetched + 1
If Fetched = VntCount Then Exit Do
VntArrPtr = UnsignedAdd(VntArrPtr, VARIANT_CB)
Loop
End With
If Fetched = VntCount Then
IEnumVARIANT_Next = S_OK
Else
IEnumVARIANT_Next = S_FALSE
End If
If VarPtr(pcvFetched) <> 0 Then pcvFetched = Fetched
Exit Function
CATCH_EXCEPTION:
If VarPtr(pcvFetched) <> 0 Then pcvFetched = 0
IEnumVARIANT_Next = E_NOTIMPL
End Function
Private Function IEnumVARIANT_Skip(ByRef This As VTableIEnumVARIANTDataStruct, ByVal VntCount As Long) As Long
IEnumVARIANT_Skip = E_NOTIMPL
End Function
Private Function IEnumVARIANT_Reset(ByRef This As VTableIEnumVARIANTDataStruct) As Long
IEnumVARIANT_Reset = E_NOTIMPL
End Function
Private Function IEnumVARIANT_Clone(ByRef This As VTableIEnumVARIANTDataStruct, ByRef ppEnum As IEnumVARIANT) As Long
IEnumVARIANT_Clone = E_NOTIMPL
End Function
Private Function GetHiddenMainWindow() As Long
EnumThreadWindows App.ThreadID, AddressOf EnumThreadWndProc, VarPtr(GetHiddenMainWindow)
End Function
Private Function EnumThreadWndProc(ByVal hwnd As Long, ByVal lpResult As Long) As Long
Dim ClassName As String
EnumThreadWndProc = 1
If GetWindowLong(hwnd, GWL_HWNDPARENT) = 0 Then
ClassName = GetWindowClassName(hwnd)
If InStr(ClassName, "Thunder") = 1 Then
If InStr(ClassName, "Main") = (Len(ClassName) - 3) Then
CopyMemory ByVal lpResult, hwnd, 4
EnumThreadWndProc = 0
End If
End If
End If
End Function

复制代码

WavFilePlaying.bas

Private Declare Function sndPlaySoundFromMemory Lib "winmm.dll" Alias "sndPlaySoundA" (lpszSoundName As Any, ByVal uFlags As Long) As Long
Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Private Declare Function sndPlaySoundStop Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As Long, ByVal uFlags As Long) As Long
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_NODEFAULT = &H2
Const SND_MEMORY = &H4
Const SND_LOOP = &H8
' SND_SYNC(=&H0) 同步调用，声音播放完毕程序才能继续
' SND_ASYNC(=&H1) 非同步调用，不必等声音播放完毕程序即可继续
' SND_NODEFAULT(=&H2)当声音文件未找到就停止播音返回
' SND_MEMORY(&H4) 播放内存中的声音
' SND_LOOP(=&H8) 声音播放完毕后从头重复播放与SND_ASYNC(=&H1)使用
' SND_NOSTOP(=&H10) 如果其他声音正在播放则不终止该声音的播放，而返回False
'从资源中播放声音
Public Sub PlaySoundFromRES(ByVal ResID As Byte)
StopSound
Dim bArr() As Byte
bArr = LoadResData(ResID, "CUSTOM")
sndPlaySoundFromMemory bArr(0), SND_ASYNC Or SND_NODEFAULT Or SND_MEMORY
End Sub
'从文件播放声音
Public Sub PlaySoundFromFile(ByVal FilePath As String, Optional ByVal ByASYNC As Boolean = True)
sndPlaySound FilePath, IIf(ByASYNC, SND_ASYNC, SND_SYNC)
End Sub
'停止播放
Public Sub StopSound()
sndPlaySoundStop 0, SND_SYNC
End Sub

复制代码

TransparentWindowAndStickedWindow.bas

Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crkey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
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 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 WS_EX_LAYERED = &H80000
Public Const GWL_EXSTYLE = (-20)
Public Const LWA_ALPHA = &H2 '透明度有效，透明颜色无效
Public Const LWA_COLORKEY = &H1 '透明度无效，透明颜色有效
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const HWND_TOPMOST = -1 '置顶
Public Const HWND_NOTOPMOST = -2 '取消置顶
Public Sub StickWindow(ByRef ObjForm As Form)
SetWindowPos ObjForm.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE '设置窗口置顶
End Sub
Public Sub UnstickWindow(ByRef ObjForm As Form)
SetWindowPos ObjForm.hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE '取消窗口置顶
End Sub
Public Function TransparentByColor(ByVal TransparentColor As OLE_COLOR, ByVal ObjForm As Form) As Boolean
On Error GoTo ExitFunction
Dim rtn As Long, hwnd As Long
hwnd = ObjForm.hwnd
rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong hwnd, GWL_EXSTYLE, rtn
SetLayeredWindowAttributes hwnd, TransparentColor, 255, LWA_COLORKEY '透明颜色
TransparentByColor = True
Exit Function
ExitFunction:
TransparentByColor = False
End Function
Public Function TransparentByTsprc(ByVal Transparency As Byte, ByVal ObjForm As Form) As Boolean
On Error GoTo ExitFunction
Dim rtn As Long, hwnd As Long
hwnd = ObjForm.hwnd
rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong hwnd, GWL_EXSTYLE, rtn
SetLayeredWindowAttributes hwnd, 0, Transparency, LWA_ALPHA '透明度
TransparentByTsprc = True
Exit Function
ExitFunction:
TransparentByTsprc = False
End Function
Public Function TransparentByValue(ByVal Value As Integer, ByVal ObjForm As Form) As Boolean
Select Case Value
Case Is <= 0
TransparentByTsprc 0, ObjForm
Case Is >= 100
TransparentByTsprc 255, ObjForm
Case Else
Dim tAlpha As Integer
tAlpha = Int(255 * Value / 100)
TransparentByTsprc CByte(tAlpha), ObjForm
End Select
End Function

复制代码

Universal.bas

Public Note() As String, NoteIndex As Long, NoteTotal As Long
Public AutoRun As Boolean '开机自启动
Public CurrIndex As Long '当前编辑的便笺索引
Public IsTally As Boolean '是否在记账状态
Public Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Integer, lpWSAData As WSADATA) As Long
Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Public Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHostname As String) As Long
Public Const WS_VERSION_REQD = &H101
Public Declare Sub InitCommonControls Lib "comctl32" ()
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Todo() As tTodo, TodoIndex As Long, R As Long, TodoTotal As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Type tTodo
Title As String '内容
TTime As String
State As eState '表示待办的状态，分为计时中、已完成和待完成（无计时）三种状态值
Action As eAction '表示执行的动作枚举
ExtraInfo As String '动作额外参数，这跟动作有关联
End Type
Public Type WSADATA
wversion As Integer
wHighVersion As Integer
szDescription(0 To 256) As Byte
szSystemStatus(0 To 128) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpszVendorInfo As Long
End Type
Public Enum eState '代办状态
Timing = 0 '计时中
Done = 1 '已完成
Unfinished = 2 '待完成（无计时）
End Enum
Public Enum eAction '动作
PowerOption = 0
ShowPrompt = 1
PlayMusic = 2
OpenFile = 3
ExecuteCommand = 4
End Enum
Public Function 减一秒(ByVal OTime As String) As String
'因为只有倒计时才需要减一秒，所以前面必为 -
Dim HH%, MM%, SS%
'时间格式为-xx:xx:xx
HH = Val(Mid(OTime, 2, 2))
MM = Val(Mid(OTime, 5, 2))
SS = Val(Mid(OTime, 8, 2))
'Debug.Print HH; " "; MM; " "; SS
SS = SS - 1
If SS = -1 Then SS = 59: MM = MM - 1
If MM = -1 Then MM = 59: HH = HH - 1
If HH = 0 And MM = 0 And SS = 0 Then
减一秒 = "-**:**:**" '表示时间停止
Else
减一秒 = "-" & Format(HH, "00") & ":" & Format(MM, "00") & ":" & Format(SS, "00")
End If
End Function
'检测网络连接
Public Function IsConnectedState() As Boolean '检测网络连接
Dim udtWSAD As WSADATA
Call WSAStartup(WS_VERSION_REQD, udtWSAD)
IsConnectedState = CBool(gethostbyname("translate.google.cn"))
Call WSACleanup
End Function
'从字符串左侧取出基于字符长度的字符串
Public Function SetTextLengthFromLeft(ByVal strText As String, ByVal Length As Long) As String
If Length <= 0 Then '长度不为负数
MsgBox "SetTextLengthFromLeft的Length不能小于1！", vbCritical
SetTextLengthFromLeft = ""
Exit Function
End If
Dim LengthTotal As Long, t As Long
LengthTotal = GetTextLengthA(strText) '获得总长度
If Length > LengthTotal Then
'要提取的字符串比源字符串长，则全部输出
SetTextLengthFromLeft = strText
Else
Dim strTemp As String, i As Long, strChar As String, currL As Long
For i = 1 To Len(strText)
strChar = Mid(strText, i, 1) '提取单个字符
If GetTextLengthA(strChar) = 1 Then '英文字符
currL = currL + 1
If currL = Length Then '刚刚好相等
strTemp = strTemp & strChar
Exit For
ElseIf currL < Length Then '还需要字符
strTemp = strTemp & strChar
End If
ElseIf GetTextLengthA(strChar) = 2 Then '中文字符
currL = currL + 2
If currL = Length Then '刚刚好相等
strTemp = strTemp & strChar
Exit For
ElseIf currL < Length Then '还需要字符
strTemp = strTemp & strChar
ElseIf currL > Length Then '字符数超过，例如需要21个字符时，最后一个是汉字
Exit For
End If
End If
Next i
SetTextLengthFromLeft = strTemp
End If
End Function
'判断一个Ansi字符串的长度
'一个中文字符长度为2，一个英文字符长度为1
Public Function GetTextLengthA(ByVal strText As String) As Double
Dim intX As Double
Dim lngTextLength As Double
lngTextLength = Len(strText) '返回Unicode的长度
For intX = 1 To lngTextLength
'Asc()：英文字符（除了大写W）返回值大于零，中文字符返回值小于零
If Asc(Mid$(strText, intX, 1)) < 0 Or Mid$(strText, intX, 1) = "W" Then lngTextLength = lngTextLength + 1
Next
GetTextLengthA = lngTextLength
End Function
Public Sub ShowMessage(Message As String, Title As String)
Load FrmMessage
FrmMessage.LblMessage.Caption = Message
FrmMessage.LblFormTitle.Caption = Title
FrmMessage.Show 1
End Sub
Public Sub ShowMusicAlert(TodoID As Long)
Load FrmMusic
FrmMusic.Tag = CStr(TodoID)
FrmMusic.WMP.url = Todo(TodoID).ExtraInfo
FrmMusic.LblFormTitle.Caption = "提醒"
FrmMusic.Show 1
End Sub
'运行/打开文件
Public Sub RunFile(FilePath As String)
If Dir(FilePath) = "" Then Exit Sub
Dim Suffix As String, FileFolder As String, FileName As String
Suffix = LCase(Right(FilePath, Len(FilePath) - InStrRev(FilePath, "."))) '获得文件后缀
FileFolder = Left(FilePath, InStrRev(FilePath, ""))
If Right(FileFolder, 1) <> "" Then FileFolder = FileFolder & "" '获得文件夹
FileName = Right(FilePath, Len(FilePath) - Len(FileFolder)) '获得文件名
Select Case Suffix
Case "bat", "exe"
Shell FilePath, vbNormalFocus
Case "py"
Shell "python " & FilePath, vbNormalFocus
Case "java"
Open FileFolder & "RunBat.bat" For Output As #2
Print #2, "@echo off"
Print #2, Left(FileFolder, 2)
Print #2, "cd " & Left(FileFolder, Len(FileFolder) - 1)
Print #2, "javac " & FileName
Print #2, "java " & Left(FileName, Len(FileName) - 5)
' MsgBox Left(FileName, Len(FileName) - 5)
Print #2, "del " & Left(FileName, Len(FileName) - 5) & ".class"
Print #2, "del %0"
Close #2
Sleep 50
Shell FileFolder & "RunBat.bat", vbNormalFocus
Case "jar"
Shell "java -jar " & FilePath, vbNormalFocus
Case Else
ShellExecute FrmMain.hwnd, "open", FilePath, vbNullString, vbNullString, 1
End Select
End Sub

复制代码

MouseWheelSupport.bas

Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Const GWL_WNDPROC = (-4)
Public Const WM_MOUSEWHEEL = &H20A
Public PrevWndProc As Long
Public Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long '‘写自己处理鼠标滚动的事件，这里让Form上下滚动
Dim t(0 To 1) As Integer
If uMsg = WM_MOUSEWHEEL Then
If wParam < 0 Then '滚轮向下
Call WheelDown
Else '滚轮向上
Call WheelUp
End If
Else
WndProc = CallWindowProc(PrevWndProc, hwnd, uMsg, wParam, lParam) '‘让Windows处理其他事件
End If
End Function
'滚轮向下的事件
Public Sub WheelDown()
Debug.Print "滚轮向下"
If FrmMain.TxtHour.Tag = "1" And Val(FrmMain.TxtHour.Text) < 23 Then FrmMain.TxtHour.Text = Format(Val(FrmMain.TxtHour.Text) + 1, "00")
If FrmMain.TxtMinute.Tag = "1" And Val(FrmMain.TxtMinute.Text) < 59 Then FrmMain.TxtMinute.Text = Format(Val(FrmMain.TxtMinute.Text) + 1, "00")
End Sub
'滚轮向上的事件
Public Sub WheelUp()
Debug.Print "滚轮向上"
If FrmMain.TxtHour.Tag = "1" And Val(FrmMain.TxtHour.Text) > 0 Then FrmMain.TxtHour.Text = Format(Val(FrmMain.TxtHour.Text) - 1, "00")
If FrmMain.TxtMinute.Tag = "1" And Val(FrmMain.TxtMinute.Text) > 0 Then FrmMain.TxtMinute.Text = Format(Val(FrmMain.TxtMinute.Text) - 1, "00")
End Sub
''将下列代码复制到窗体模块内，即可实现鼠标滚轮的响应。
'Private Sub Form_Load()
' PrevWndProc = SetWindowLong(Me.hwnd, GWL_WNDPROC, AddressOf WndProc) '让WndProc来处理该窗体的事件
'End Sub
'
'Private Sub Form_Unload(Cancel As Integer)
' Dim lResult As Long
' lResult = SetWindowLong(Me.hwnd, GWL_WNDPROC, PrevWndProc) '让Windows默认的函数来处理事件
'End Sub

复制代码

MovingWindowWithoutBorder.bas

Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1
Public Sub MoveFormWithoutBorder(ByVal ObjForm As Form)
'此函数在MouseDown中调用
ReleaseCapture
SendMessage ObjForm.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub

复制代码

ReadingAndWritingReg_AutoStartAfterSystemLoginedIncluded

'---------------------------------------------------------------
'-注册表 API 声明...
'---------------------------------------------------------------
'关闭登录关键字
Public Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
'建立关键字
Public Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegCreateKeyEx Lib "advapi32" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, ByRef phkResult As Long, ByRef lpdwDisposition As Long) As Long
'打开关键字
Public Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
'返回关键字的类型和值
Public Declare Function RegQueryValueEx_SZ Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
Public Declare Function RegQueryValueEx_DWORD Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, ByRef lpcbData As Long) As Long
'将文本字符串与指定关键字关联
Public Declare Function RegSetValueEx_SZ Lib "advapi32" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Public Declare Function RegSetValueEx_DWORD Lib "advapi32" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Long, ByVal cbData As Long) As Long
Public Declare Function RegSetValueEx_BINARY Lib "advapi32" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
'删除关键字
Public Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
'从登录关键字中删除一个值
Public Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
' 注册表的数据类型
Public Enum REGValueType
REG_SZ = 1 ' Unicode空终结字符串
REG_EXPAND_SZ = 2 ' Unicode空终结字符串
REG_BINARY = 3 ' 二进制数值
REG_DWORD = 4 ' 32-bit 数字
REG_DWORD_BIG_ENDIAN = 5
REG_LINK = 6
REG_MULTI_SZ = 7 ' 二进制数值串
End Enum
' 注册表创建类型值...
Const REG_OPTION_NON_VOLATILE = 0 ' 当系统重新启动时，关键字被保留
' 注册表关键字安全选项...
Const READ_CONTROL = &H20000
Const KEY_QUERY_VALUE = &H1
Const KEY_SET_VALUE = &H2
Const KEY_CREATE_SUB_KEY = &H4
Const KEY_ENUMERATE_SUB_KEYS = &H8
Const KEY_NOTIFY = &H10
Const KEY_CREATE_LINK = &H20
Const KEY_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
Const KEY_WRITE = KEY_SET_VALUE + KEY_CREATE_SUB_KEY + READ_CONTROL
Const KEY_EXECUTE = KEY_READ
Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
' 注册表关键字根类型...
Public Enum REGRoot
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_USER = &H80000001
HKEY_LOCAL_MACHINE = &H80000002
HKEY_USERS = &H80000003
HKEY_PERFORMANCE_DATA = &H80000004
End Enum
' 返回值...
Const ERROR_NONE = 0
Const ERROR_BADKEY = 2
Const ERROR_ACCESS_DENIED = 8
Const ERROR_SUCCESS = 0
'- 注册表安全属性类型...
Public Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
'*************************************************************************
'**函数名：WriteRegKey
'**输入：ByVal KeyRoot(REGRoot) - 根
'** ：ByVal KeyName(String) - 键的路径
'** ：ByVal SubKeyName(String) - 键名
'** ：ByVal SubKeyType(REGValueType) - 键的类型
'** ：ByVal SubKeyValue(String) - 键值
'**输出：(Boolean) - 成功返回True，失败返回False
'**功能描述：写注册表
'**全局变量：
'**调用模块：
'**作者：叶帆
'**日期：2003年01月10日
'**修改人：
'**日期：
'**版本：版本1.0
'*************************************************************************
Public Function WriteRegKey(ByVal KeyRoot As REGRoot, ByVal KeyName As String, ByVal SubKeyName As String, ByVal SubKeyType As REGValueType, ByVal SubKeyValue As String) As Boolean
Dim RC As Long ' 返回代码
Dim hKey As Long ' 处理一个注册表关键字
Dim hDepth As Long ' 用于装载下列某个常数的一个变量
' REG_CREATED_NEW_KEY——新建的一个子项
' REG_OPENED_EXISTING_KEY——打开一个现有的项
Dim lpAttr As SECURITY_ATTRIBUTES ' 注册表安全类型
Dim i As Integer
Dim bytValue(1024) As Byte
lpAttr.nLength = 50 ' 设置安全属性为缺省值...
lpAttr.lpSecurityDescriptor = 0 ' ...
lpAttr.bInheritHandle = True ' ...
'- 创建/打开注册表关键字...
RC = RegCreateKeyEx(KeyRoot, KeyName, 0, SubKeyType, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, lpAttr, hKey, hDepth) ' 创建/打开//KeyRoot//KeyName
If (RC <> ERROR_SUCCESS) Then GoTo CreateKeyError ' 错误处理...
'- 创建/修改关键字值...
If (SubKeyValue = "") Then SubKeyValue = " " ' 要让RegSetValueEx() 工作需要输入一个空格...
Select Case SubKeyType ' 搜索数据类型...
Case REG_SZ, REG_EXPAND_SZ ' 字符串注册表关键字数据类型
RC = RegSetValueEx_SZ(hKey, SubKeyName, 0, SubKeyType, ByVal SubKeyValue, LenB(StrConv(SubKeyValue, vbFromUnicode)))
If (RC <> ERROR_SUCCESS) Then GoTo CreateKeyError ' 错误处理
Case REG_DWORD ' 四字节注册表关键字数据类型
RC = RegSetValueEx_DWORD(hKey, SubKeyName, 0, SubKeyType, Val("&h" + SubKeyValue), 4)
If (RC <> ERROR_SUCCESS) Then GoTo CreateKeyError ' 错误处理
Case REG_BINARY ' 二进制字符串
Dim intNum As Integer
For i = 1 To Len(Trim$(SubKeyValue)) - 1 Step 3
intNum = intNum + 1
bytValue(intNum - 1) = Val("&h" + Mid$(SubKeyValue, i, 2))
Next i
RC = RegSetValueEx_BINARY(hKey, SubKeyName, 0, SubKeyType, bytValue(0), intNum)
If (RC <> ERROR_SUCCESS) Then GoTo CreateKeyError ' 错误处理
Case Else
GoTo CreateKeyError ' 错误处理
End Select
'- 关闭注册表关键字...
RC = RegCloseKey(hKey) ' 关闭关键字
WriteRegKey = True ' 返回成功
Exit Function ' 退出
CreateKeyError:
WriteRegKey = False ' 设置错误返回代码
RC = RegCloseKey(hKey) ' 试图关闭关键字
End Function
'*************************************************************************
'**函数名：ReadRegKey
'**输入：KeyRoot(Long) - 根
'** ：KeyName(String) - 键的路径
'** ：SubKeyRef(String) - 键名
'**输出：(String) - 返回键值
'**功能描述：读注册表
'**全局变量：
'**调用模块：
'**作者：叶帆
'**日期：2003年01月10日
'**修改人：
'**日期：
'**版本：版本1.0
'*************************************************************************
Public Function ReadRegKey(ByVal KeyRoot As REGRoot, ByVal KeyName As String, ByVal SubKeyName As String) As String
Dim i As Long ' 循环计数器
Dim RC As Long ' 返回代码
Dim hKey As Long ' 处理打开的注册表关键字
Dim hDepth As Long '
Dim sKeyVal As String
Dim lKeyValType As Long ' 注册表关键字数据类型
Dim tmpVal As String ' 注册表关键字的临时存储器
Dim KeyValSize As Long ' 注册表关键字变量尺寸
Dim LngValue As Long
Dim bytValue(1024) As Byte
' 在 KeyRoot下打开注册表关键字
RC = RegOpenKeyEx(KeyRoot, KeyName, 0, KEY_ALL_ACCESS, hKey) ' 打开注册表关键字
If (RC <> ERROR_SUCCESS) Then GoTo GetKeyError ' 处理错误...
' 检测键的类型
RC = RegQueryValueEx(hKey, SubKeyName, 0, lKeyValType, ByVal 0, KeyValSize) ' 获得/创建关键字的值lKeyValType
If (RC <> ERROR_SUCCESS) Then GoTo GetKeyError ' 处理错误...
'读相应的键值
Select Case lKeyValType ' 搜索数据类型...
Case REG_SZ, REG_EXPAND_SZ ' 字符串注册表关键字数据类型
tmpVal = String$(1024, 0) ' 分配变量空间
KeyValSize = 1024 ' 标记变量尺寸
RC = RegQueryValueEx_SZ(hKey, SubKeyName, 0, 0, tmpVal, KeyValSize) ' 获得/创建关键字的值
If RC <> ERROR_SUCCESS Then GoTo GetKeyError ' 错误处理
If InStr(tmpVal, Chr$(0)) > 0 Then sKeyVal = Left$(tmpVal, InStr(tmpVal, Chr$(0)) - 1) ' 复制字符串的值,并去除空字符.
Case REG_DWORD ' 四字节注册表关键字数据类型
KeyValSize = 1024 ' 标记变量尺寸
RC = RegQueryValueEx_DWORD(hKey, SubKeyName, 0, 0, LngValue, KeyValSize) ' 获得/创建关键字的值
If RC <> ERROR_SUCCESS Then GoTo GetKeyError ' 错误处理
sKeyVal = "0x" + Hex$(LngValue)
Case REG_BINARY ' 二进制字符串
RC = RegQueryValueEx(hKey, SubKeyName, 0, 0, bytValue(0), KeyValSize) ' 获得/创建关键字的值
If RC <> ERROR_SUCCESS Then GoTo GetKeyError ' 错误处理
sKeyVal = ""
For i = 1 To KeyValSize
If Len(Hex$(bytValue(i - 1))) = 1 Then
sKeyVal = sKeyVal + "0" + Hex$(bytValue(i - 1)) + " "
Else
sKeyVal = sKeyVal + Hex$(bytValue(i - 1)) + " "
End If
Next i
Case Else
sKeyVal = ""
End Select
ReadRegKey = sKeyVal ' 返回值
RC = RegCloseKey(hKey) ' 关闭注册表关键字
Exit Function ' 退出
GetKeyError:
' 错误发生过后进行清除...
ReadRegKey = "" ' 设置返回值为错误
RC = RegCloseKey(hKey) ' 关闭注册表关键字
End Function
'*************************************************************************
'**函数名：DelRegKey
'**输入：KeyRoot(Long) - 根
'** ：KeyName(String) - 键的路径
'** ：SubKeyRef(String) - 键名
'**输出：(Long) - 状态码
'**功能描述：删除关键字
'**全局变量：
'**调用模块：
'**作者：叶帆
'**日期：2003年01月11日
'**修改人：
'**日期：
'**版本：版本1.0
'*************************************************************************
Public Function DelRegKey(ByVal KeyRoot As REGRoot, ByVal KeyName As String, ByVal SubKeyName As String) As Long
Dim lKeyId As Long
Dim lResult As Long
'检测设置的参数
If Len(KeyName) = 0 And Len(SubKeyName) = 0 Then
' 键值没设置则返回相应错误码
DelRegKey = ERROR_BADKEY
Exit Function
End If
' 打开关键字并尝试创建它,如果已存在,则返回ID值
lResult = RegCreateKey(KeyRoot, KeyName, lKeyId)
If lResult = 0 Then
'删除关键字
DelRegKey = RegDeleteKey(lKeyId, ByVal SubKeyName)
End If
End Function
'*************************************************************************
'**函数名：DelRegValue
'**输入：KeyRoot(Long) - 根
'** ：KeyName(String) - 键的路径
'** ：SubKeyRef(String) - 键名
'**输出：(Long) - 状态码
'**功能描述：从登录关键字中删除一个值
'**全局变量：
'**调用模块：
'**作者：叶帆
'**日期：2003年01月11日
'**修改人：
'**日期：
'**版本：版本1.0
'*************************************************************************
Public Function DelRegValue(ByVal KeyRoot As REGRoot, ByVal KeyName As String, ByVal SubKeyName As String) As Long
Dim lKeyId As Long
Dim lResult As Long
'检测设置的参数
If Len(KeyName) = 0 And Len(SubKeyName) = 0 Then
' 键值没设置则返回相应错误码
DelRegValue = ERROR_BADKEY
Exit Function
End If
' 打开关键字并尝试创建它,如果已存在,则返回ID值
lResult = RegCreateKey(KeyRoot, KeyName, lKeyId)
If lResult = 0 Then
'从登录关键字中删除一个值
DelRegValue = RegDeleteValue(lKeyId, ByVal SubKeyName)
End If
End Function
Public Sub AddStart() '增加开机启动项
WriteRegKey HKEY_LOCAL_MACHINE, ByVal "Software\Microsoft\Windows\CurrentVersion\Run", ByVal App.EXEName, REG_SZ, ByVal App.Path & "" & App.EXEName & ".exe"
'WriteRegKey 主键 , ByVal 路径 , ByVal 名称 , 类型 , ByVal 数据
End Sub
Public Sub DeleteStart() '删除开机启动项
DelRegValue HKEY_LOCAL_MACHINE, ByVal "Software\Microsoft\Windows\CurrentVersion\Run", ByVal App.EXEName
End Sub

复制代码

CommonDialog.cls

Option Explicit
#If False Then
Private CdlCancel, CdlBufferTooSmall, CdlInvalidFileName, CdlSubclassFailure, CdlMaxLessThanMin, CdlNoFonts, CdlPrinterNotFound, CdlCreateICFailure, CdlDndmMismatch, CdlNoDefaultPrn, CdlNoDevices, CdlInitFailure, CdlGetDevModeFail, CdlLoadDrvFailure, CdlRetDefFailure, CdlParseFailure, CdlHelp, CdlBufferLengthZero
Private CdlPRORPortrait, CdlPRORLandscape
Private CdlPRPSLetter, CdlPRPSLetterSmall, CdlPRPSTabloid, CdlPRPSLedger, CdlPRPSLegal, CdlPRPSStatement, CdlPRPSExecutive, CdlPRPSA3, CdlPRPSA4, CdlPRPSA4Small, CdlPRPSA5, CdlPRPSB4, CdlPRPSB5, CdlPRPSFolio, CdlPRPSQuarto, CdlPRPS10x14, CdlPRPS11x17, CdlPRPSNote, CdlPRPSEnv9, CdlPRPSEnv10, CdlPRPSEnv11, CdlPRPSEnv12, CdlPRPSEnv14, CdlPRPSCSheet, CdlPRPSDSheet, CdlPRPSESheet, CdlPRPSEnvDL, CdlPRPSEnvC5, CdlPRPSEnvC3, CdlPRPSEnvC4, CdlPRPSEnvC6, CdlPRPSEnvC65, CdlPRPSEnvB4, CdlPRPSEnvB5, CdlPRPSEnvB6, CdlPRPSEnvItaly, CdlPRPSEnvMonarch, CdlPRPSEnvPersonal, CdlPRPSFanfoldUS, CdlPRPSFanfoldStdGerman, CdlPRPSFanfoldLglGerman, CdlPRPSUser
Private CdlPRBNUpper, CdlPRBNLower, CdlPRBNMiddle, CdlPRBNManual, CdlPRBNEnvelope, CdlPRBNEnvManual, CdlPRBNAuto, CdlPRBNTractor, CdlPRBNSmallFmt, CdlPRBNLargeFmt, CdlPRBNLargeCapacity, CdlPRBNCassette
Private CdlPRPQHigh, CdlPRPQMedium, CdlPRPQLow, CdlPRPQDraft
Private CdlPRCMMonochrome, CdlPRCMColor
Private CdlPRDPSimplex, CdlPRDPHorizontal, CdlPRDPVertical
Private CdlOFNReadOnly, CdlOFNOverwritePrompt, CdlOFNHideReadOnly, CdlOFNNoChangeDir, CdlOFNHelpButton, CdlOFNNoValidate, CdlOFNAllowMultiSelect, CdlOFNExtensionDifferent, CdlOFNPathMustExist, CdlOFNFileMustExist, CdlOFNCreatePrompt, CdlOFNShareAware, CdlOFNNoReadOnlyReturn, CdlOFNNoNetworkButton, CdlOFNExplorer, CdlOFNNoDereferenceLinks, CdlOFNDontAddToRecent, CdlOFNForcesShowHidden
Private CdlOFNShareViResultWarn, CdlOFNShareViResultNoWarn, CdlOFNShareViResultFallThrough
Private CdlCCRGBInit, CdlCCFullOpen, CdlCCPreventFullOpen, CdlCCHelpButton, CdlCCSolidColor, CdlCCAnyColor
Private CdlCFScreenFonts, CdlCFPrinterFonts, CdlCFHelpButton, CdlCFEffects, CdlCFApply, CdlCFScriptsOnly, CdlCFNoVectorFonts, CdlCFLimitSize, CdlCFFixedPitchOnly, CdlCFForceFontExist, CdlCFScalableOnly, CdlCFTTOnly, CdlCFNoFaceSel, CdlCFNoStyleSel, CdlCFNoSizeSel, CdlCFSelectScript, CdlCFNoScriptSel, CdlCFNoVertFonts
Private CdlPDAllPages, CdlPDSelection, CdlPDPageNums, CdlPDNoSelection, CdlPDNoPageNums, CdlPDCollate, CdlPDPrintToFile, CdlPDPrintSetup, CdlPDNoWarning, CdlPDReturnDC, CdlPDReturnIC, CdlPDReturnDefault, CdlPDHelpButton, CdlPDUseDevModeCopies, CdlPDUseDevModeCopiesAndCollate, CdlPDDisablePrintToFile, CdlPDCurrentPage, CdlPDHidePrintToFile, CdlPDNoNetworkButton, CdlPDNoCurrentPage
Private CdlPDResultCancel, CdlPDResultPrint, CdlPDResultApply
Private CdlHelpContext, CdlHelpQuit, CdlHelpIndex, CdlHelpContents, CdlHelpHelpOnHelp, CdlHelpSetIndex, CdlHelpSetContents, CdlHelpContextPopup, CdlHelpForceFile, CdlHelpKey, CdlHelpCommandHelp, CdlHelpPartialKey
Private CdlPSDDefaultMinMargins, CdlPSDMinMargins, CdlPSDMargins, CdlPSDInThousandthsOfInches, CdlPSDInHundredthsOfMillimeters, CdlPSDDisableMargins, CdlPSDDisablePrinter, CdlPSDNoWarning, CdlPSDDisableOrientation, CdlPSDDisablePaper, CdlPSDReturnDefault, CdlPSDHelpButton, CdlPSDDisablePagePainting, CdlPSDNoNetworkButton
Private CdlBIFReturnOnlyFSDirs, CdlBIFDontGoBelowDomain, CdlBIFStatusText, CdlBIFReturnFSAncestors, CdlBIFEditBox, CdlBIFValidate, CdlBIFNewDialogStyle, CdlBIFBrowseIncludeURLs, CdlBIFUseNewUI, CdlBIFUAHint, CdlBIFNoNewFolderButton, CdlBIFNoTranslateTargets, CdlBIFBrowseForComputer, CdlBIFBrowseForPrinter, CdlBIFBrowseIncludeFiles, CdlBIFShareable, CdlBIFBrowseFileJunctions
Private CdlFRDown, CdlFRWholeWord, CdlFRMatchCase, CdlFRFindNext, CdlFRReplace, CdlFRReplaceAll, CdlFRHelpButton, CdlFRNoUpDown, CdlFRNoMatchCase, CdlFRNoWholeWord, CdlFRHideUpDown, CdlFRHideMatchCase, CdlFRHideWholeWord
Private CdlOAIFAllowRegistration, CdlOAIFRegisterExt, CdlOAIFExecute, CdlOAIFForceRegistration, CdlOAIFHideRegistration, CdlOAIFURLProtocol
#End If
Private Const FNERR_BUFFERTOOSMALL As Long = &H3003
Private Const FNERR_INVALIDFILENAME As Long = &H3002
Private Const FNERR_SUBCLASSFAILURE As Long = &H3001
Private Const CFERR_MAXLESSTHANMIN As Long = &H2002
Private Const CFERR_NOFONTS As Long = &H2001
Private Const PDERR_PRINTERNOTFOUND As Long = &H100B
Private Const PDERR_CREATEICFAILURE As Long = &H100A
Private Const PDERR_DNDMMISMATCH As Long = &H1009
Private Const PDERR_NODEFAULTPRN As Long = &H1008
Private Const PDERR_NODEVICES As Long = &H1007
Private Const PDERR_INITFAILURE As Long = &H1006
Private Const PDERR_GETDEVMODEFAIL As Long = &H1005
Private Const PDERR_LOADDRVFAILURE As Long = &H1004
Private Const PDERR_RETDEFFAILURE As Long = &H1003
Private Const PDERR_PARSEFAILURE As Long = &H1002
Private Const FRERR_BUFFERLENGTHZERO As Long = &H4001
Public Enum CdlErrorConstants
CdlCancel = 32755
CdlBufferTooSmall = 20476
CdlInvalidFileName = 20477
CdlSubclassFailure = 20478
CdlMaxLessThanMin = 24573
CdlNoFonts = 24574
CdlPrinterNotFound = 28660
CdlCreateICFailure = 28661
CdlDndmMismatch = 28662
CdlNoDefaultPrn = 28663
CdlNoDevices = 28664
CdlInitFailure = 28665
CdlGetDevModeFail = 28666
CdlLoadDrvFailure = 28667
CdlRetDefFailure = 28668
CdlParseFailure = 28669
CdlHelp = 32751
CdlBufferLengthZero = 36848
End Enum
Public Enum CdlPRORConstants
CdlPRORPortrait = vbPRORPortrait
CdlPRORLandscape = vbPRORLandscape
End Enum
Public Enum CdlPRPSConstants
CdlPRPSLetter = vbPRPSLetter
CdlPRPSLetterSmall = vbPRPSLetterSmall
CdlPRPSTabloid = vbPRPSTabloid
CdlPRPSLedger = vbPRPSLedger
CdlPRPSLegal = vbPRPSLegal
CdlPRPSStatement = vbPRPSStatement
CdlPRPSExecutive = vbPRPSExecutive
CdlPRPSA3 = vbPRPSA3
CdlPRPSA4 = vbPRPSA4
CdlPRPSA4Small = vbPRPSA4Small
CdlPRPSA5 = vbPRPSA5
CdlPRPSB4 = vbPRPSB4
CdlPRPSB5 = vbPRPSB5
CdlPRPSFolio = vbPRPSFolio
CdlPRPSQuarto = vbPRPSQuarto
CdlPRPS10x14 = vbPRPS10x14
CdlPRPS11x17 = vbPRPS11x17
CdlPRPSNote = vbPRPSNote
CdlPRPSEnv9 = vbPRPSEnv9
CdlPRPSEnv10 = vbPRPSEnv10
CdlPRPSEnv11 = vbPRPSEnv11
CdlPRPSEnv12 = vbPRPSEnv12
CdlPRPSEnv14 = vbPRPSEnv14
CdlPRPSCSheet = vbPRPSCSheet
CdlPRPSDSheet = vbPRPSDSheet
CdlPRPSESheet = vbPRPSESheet
CdlPRPSEnvDL = vbPRPSEnvDL
CdlPRPSEnvC5 = vbPRPSEnvC5
CdlPRPSEnvC3 = vbPRPSEnvC3
CdlPRPSEnvC4 = vbPRPSEnvC4
CdlPRPSEnvC6 = vbPRPSEnvC6
CdlPRPSEnvC65 = vbPRPSEnvC65
CdlPRPSEnvB4 = vbPRPSEnvB4
CdlPRPSEnvB5 = vbPRPSEnvB5
CdlPRPSEnvB6 = vbPRPSEnvB6
CdlPRPSEnvItaly = vbPRPSEnvItaly
CdlPRPSEnvMonarch = vbPRPSEnvMonarch
CdlPRPSEnvPersonal = vbPRPSEnvPersonal
CdlPRPSFanfoldUS = vbPRPSFanfoldUS
CdlPRPSFanfoldStdGerman = vbPRPSFanfoldStdGerman
CdlPRPSFanfoldLglGerman = vbPRPSFanfoldLglGerman
CdlPRPSUser = vbPRPSUser
End Enum
Public Enum CdlPRBNConstants
CdlPRBNUpper = vbPRBNUpper
CdlPRBNLower = vbPRBNLower
CdlPRBNMiddle = vbPRBNMiddle
CdlPRBNManual = vbPRBNManual
CdlPRBNEnvelope = vbPRBNEnvelope
CdlPRBNEnvManual = vbPRBNEnvManual
CdlPRBNAuto = vbPRBNAuto
CdlPRBNTractor = vbPRBNTractor
CdlPRBNSmallFmt = vbPRBNSmallFmt
CdlPRBNLargeFmt = vbPRBNLargeFmt
CdlPRBNLargeCapacity = vbPRBNLargeCapacity
CdlPRBNCassette = vbPRBNCassette
End Enum
Public Enum CdlPRPQConstants
CdlPRPQHigh = vbPRPQHigh
CdlPRPQMedium = vbPRPQMedium
CdlPRPQLow = vbPRPQLow
CdlPRPQDraft = vbPRPQDraft
End Enum
Public Enum CdlPRCMConstants
CdlPRCMMonochrome = vbPRCMMonochrome
CdlPRCMColor = vbPRCMColor
End Enum
Public Enum CdlPRDPConstants
CdlPRDPSimplex = vbPRDPSimplex
CdlPRDPHorizontal = vbPRDPHorizontal
CdlPRDPVertical = vbPRDPVertical
End Enum
Private Const OFN_READONLY As Long = &H1
Private Const OFN_OVERWRITEPROMPT As Long = &H2
Private Const OFN_HIDEREADONLY As Long = &H4
Private Const OFN_NOCHANGEDIR As Long = &H8
Private Const OFN_SHOWHELP As Long = &H10
Private Const OFN_ENABLEHOOK As Long = &H20 ' Internal use only
Private Const OFN_NOVALIDATE As Long = &H100
Private Const OFN_ALLOWMULTISELECT As Long = &H200
Private Const OFN_EXTENSIONDIFFERENT As Long = &H400
Private Const OFN_PATHMUSTEXIST As Long = &H800
Private Const OFN_FILEMUSTEXIST As Long = &H1000
Private Const OFN_CREATEPROMPT As Long = &H2000
Private Const OFN_SHAREAWARE As Long = &H4000
Private Const OFN_NOREADONLYRETURN As Long = &H8000&
Private Const OFN_NONETWORKBUTTON As Long = &H20000
Private Const OFN_EXPLORER As Long = &H80000
Private Const OFN_NODEREFERENCELINKS As Long = &H100000
Private Const OFN_ENABLESIZING As Long = &H800000 ' Internal use only. Necessary only if a callback procedure or custom template is provided
Private Const OFN_DONTADDTORECENT As Long = &H2000000
Private Const OFN_FORCESHOWHIDDEN As Long = &H10000000
Public Enum CdlOFNConstants
CdlOFNReadOnly = OFN_READONLY
CdlOFNOverwritePrompt = OFN_OVERWRITEPROMPT
CdlOFNHideReadOnly = OFN_HIDEREADONLY
CdlOFNNoChangeDir = OFN_NOCHANGEDIR
CdlOFNHelpButton = OFN_SHOWHELP
CdlOFNNoValidate = OFN_NOVALIDATE
CdlOFNAllowMultiSelect = OFN_ALLOWMULTISELECT
CdlOFNExtensionDifferent = OFN_EXTENSIONDIFFERENT
CdlOFNPathMustExist = OFN_PATHMUSTEXIST
CdlOFNFileMustExist = OFN_FILEMUSTEXIST
CdlOFNCreatePrompt = OFN_CREATEPROMPT
CdlOFNShareAware = OFN_SHAREAWARE
CdlOFNNoReadOnlyReturn = OFN_NOREADONLYRETURN
CdlOFNNoNetworkButton = OFN_NONETWORKBUTTON
CdlOFNExplorer = OFN_EXPLORER
CdlOFNNoDereferenceLinks = OFN_NODEREFERENCELINKS
CdlOFNDontAddToRecent = OFN_DONTADDTORECENT
CdlOFNForcesShowHidden = OFN_FORCESHOWHIDDEN
End Enum
Private Const OFN_SHAREWARN As Long = &H0
Private Const OFN_SHARENOWARN As Long = &H1
Private Const OFN_SHAREFALLTHROUGH As Long = &H2
Public Enum CdlOFNShareViResultConstants
CdlOFNShareViResultWarn = OFN_SHAREWARN
CdlOFNShareViResultNoWarn = OFN_SHARENOWARN
CdlOFNShareViResultFallThrough = OFN_SHAREFALLTHROUGH
End Enum
Private Const CC_RGBINIT As Long = &H1
Private Const CC_FULLOPEN As Long = &H2
Private Const CC_PREVENTFULLOPEN As Long = &H4
Private Const CC_SHOWHELP As Long = &H8
Private Const CC_ENABLEHOOK As Long = &H10 ' Internal use only
Private Const CC_SOLIDCOLOR As Long = &H80
Private Const CC_ANYCOLOR As Long = &H100
Public Enum CdlCCConstants
CdlCCRGBInit = CC_RGBINIT
CdlCCFullOpen = CC_FULLOPEN
CdlCCPreventFullOpen = CC_PREVENTFULLOPEN
CdlCCHelpButton = CC_SHOWHELP
CdlCCSolidColor = CC_SOLIDCOLOR
CdlCCAnyColor = CC_ANYCOLOR
End Enum
Private Const CF_SCREENFONTS As Long = &H1
Private Const CF_PRINTERFONTS As Long = &H2
Private Const CF_SHOWHELP As Long = &H4
Private Const CF_ENABLEHOOK As Long = &H8 ' Internal use only
Private Const CF_INITTOLOGFONTSTRUCT As Long = &H40 ' Internal use only
Private Const CF_EFFECTS As Long = &H100
Private Const CF_APPLY As Long = &H200
Private Const CF_SCRIPTSONLY As Long = &H400
Private Const CF_NOVECTORFONTS As Long = &H800
Private Const CF_LIMITSIZE As Long = &H2000
Private Const CF_FIXEDPITCHONLY As Long = &H4000
Private Const CF_FORCEFONTEXIST As Long = &H10000
Private Const CF_SCALABLEONLY As Long = &H20000
Private Const CF_TTONLY As Long = &H40000
Private Const CF_NOFACESEL As Long = &H80000
Private Const CF_NOSTYLESEL As Long = &H100000
Private Const CF_NOSIZESEL As Long = &H200000
Private Const CF_SELECTSCRIPT As Long = &H400000
Private Const CF_NOSCRIPTSEL As Long = &H800000
Private Const CF_NOVERTFONTS As Long = &H1000000
Public Enum CdlCFConstants
CdlCFScreenFonts = CF_SCREENFONTS
CdlCFPrinterFonts = CF_PRINTERFONTS
CdlCFHelpButton = CF_SHOWHELP
CdlCFEffects = CF_EFFECTS
CdlCFApply = CF_APPLY
CdlCFScriptsOnly = CF_SCRIPTSONLY
CdlCFNoVectorFonts = CF_NOVECTORFONTS
CdlCFLimitSize = CF_LIMITSIZE
CdlCFFixedPitchOnly = CF_FIXEDPITCHONLY
CdlCFForceFontExist = CF_FORCEFONTEXIST
CdlCFScalableOnly = CF_SCALABLEONLY
CdlCFTTOnly = CF_TTONLY
CdlCFNoFaceSel = CF_NOFACESEL
CdlCFNoStyleSel = CF_NOSTYLESEL
CdlCFNoSizeSel = CF_NOSIZESEL
CdlCFSelectScript = CF_SELECTSCRIPT
CdlCFNoScriptSel = CF_NOSCRIPTSEL
CdlCFNoVertFonts = CF_NOVERTFONTS
End Enum
Private Const PD_ALLPAGES As Long = &H0
Private Const PD_SELECTION As Long = &H1
Private Const PD_PAGENUMS As Long = &H2
Private Const PD_NOSELECTION As Long = &H4
Private Const PD_NOPAGENUMS As Long = &H8
Private Const PD_COLLATE As Long = &H10
Private Const PD_PRINTTOFILE As Long = &H20
Private Const PD_PRINTSETUP As Long = &H40 ' PRINTDLG only
Private Const PD_NOWARNING As Long = &H80
Private Const PD_RETURNDC As Long = &H100
Private Const PD_RETURNIC As Long = &H200
Private Const PD_RETURNDEFAULT As Long = &H400
Private Const PD_SHOWHELP As Long = &H800 ' PRINTDLG only
Private Const PD_ENABLEPRINTHOOK As Long = &H1000 ' Internal use only
Private Const PD_ENABLESETUPHOOK As Long = &H2000 ' Internal use only
Private Const PD_USEDEVMODECOPIES As Long = &H40000
Private Const PD_USEDEVMODECOPIESANDCOLLATE As Long = &H40000
Private Const PD_DISABLEPRINTTOFILE As Long = &H80000
Private Const PD_CURRENTPAGE As Long = &H400000 ' PRINTDLGEX only
Private Const PD_HIDEPRINTTOFILE As Long = &H100000
Private Const PD_NONETWORKBUTTON As Long = &H200000 ' PRINTDLG only
Private Const PD_NOCURRENTPAGE As Long = &H800000 ' PRINTDLGEX only
Public Enum CdlPDConstants
CdlPDAllPages = PD_ALLPAGES
CdlPDSelection = PD_SELECTION
CdlPDPageNums = PD_PAGENUMS
CdlPDNoSelection = PD_NOSELECTION
CdlPDNoPageNums = PD_NOPAGENUMS
CdlPDCollate = PD_COLLATE
CdlPDPrintToFile = PD_PRINTTOFILE
CdlPDPrintSetup = PD_PRINTSETUP
CdlPDNoWarning = PD_NOWARNING
CdlPDReturnDC = PD_RETURNDC
CdlPDReturnIC = PD_RETURNIC
CdlPDReturnDefault = PD_RETURNDEFAULT
CdlPDHelpButton = PD_SHOWHELP
CdlPDUseDevModeCopies = PD_USEDEVMODECOPIES
CdlPDUseDevModeCopiesAndCollate = PD_USEDEVMODECOPIESANDCOLLATE
CdlPDDisablePrintToFile = PD_DISABLEPRINTTOFILE
CdlPDCurrentPage = PD_CURRENTPAGE
CdlPDHidePrintToFile = PD_HIDEPRINTTOFILE
CdlPDNoNetworkButton = PD_NONETWORKBUTTON
CdlPDNoCurrentPage = PD_NOCURRENTPAGE
End Enum
Private Const PD_RESULT_CANCEL As Long = &H0
Private Const PD_RESULT_PRINT As Long = &H1
Private Const PD_RESULT_APPLY As Long = &H2
Public Enum CdlPDResultConstants
CdlPDResultCancel = PD_RESULT_CANCEL
CdlPDResultPrint = PD_RESULT_PRINT
CdlPDResultApply = PD_RESULT_APPLY
End Enum
Private Const HELP_CONTEXT As Long = &H1
Private Const HELP_QUIT As Long = &H2
Private Const HELP_INDEX As Long = &H3
Private Const HELP_CONTENTS As Long = &H3
Private Const HELP_HELPONHELP As Long = &H4
Private Const HELP_SETINDEX As Long = &H5
Private Const HELP_SETCONTENTS As Long = &H5
Private Const HELP_CONTEXTPOPUP As Long = &H8
Private Const HELP_FORCEFILE As Long = &H9
Private Const HELP_KEY As Long = &H101
Private Const HELP_COMMAND As Long = &H102
Private Const HELP_PARTIALKEY As Long = &H105
Public Enum CdlHelpConstants
CdlHelpContext = HELP_CONTEXT
CdlHelpQuit = HELP_QUIT
CdlHelpIndex = HELP_INDEX
CdlHelpContents = HELP_CONTENTS
CdlHelpHelpOnHelp = HELP_HELPONHELP
CdlHelpSetIndex = HELP_SETINDEX
CdlHelpSetContents = HELP_SETCONTENTS
CdlHelpContextPopup = HELP_CONTEXTPOPUP
CdlHelpForceFile = HELP_FORCEFILE
CdlHelpKey = HELP_KEY
CdlHelpCommandHelp = HELP_COMMAND
CdlHelpPartialKey = HELP_PARTIALKEY
End Enum
Private Const PSD_DEFAULTMINMARGINS As Long = &H0
Private Const PSD_MINMARGINS As Long = &H1
Private Const PSD_MARGINS As Long = &H2
Private Const PSD_INTHOUSANDTHSOFINCHES As Long = &H4
Private Const PSD_INHUNDREDTHSOFMILLIMETERS As Long = &H8
Private Const PSD_DISABLEMARGINS As Long = &H10
Private Const PSD_DISABLEPRINTER As Long = &H20 ' Only for Windows XP/2000
Private Const PSD_NOWARNING As Long = &H80
Private Const PSD_DISABLEORIENTATION As Long = &H100
Private Const PSD_DISABLEPAPER As Long = &H200
Private Const PSD_RETURNDEFAULT As Long = &H400
Private Const PSD_SHOWHELP As Long = &H800
Private Const PSD_ENABLEPAGESETUPHOOK As Long = &H2000 ' Internal use only
Private Const PSD_DISABLEPAGEPAINTING As Long = &H80000
Private Const PSD_NONETWORKBUTTON As Long = &H200000
Public Enum CdlPSDConstants
CdlPSDDefaultMinMargins = PSD_DEFAULTMINMARGINS
CdlPSDMinMargins = PSD_MINMARGINS
CdlPSDMargins = PSD_MARGINS
CdlPSDInThousandthsOfInches = PSD_INTHOUSANDTHSOFINCHES
CdlPSDInHundredthsOfMillimeters = PSD_INHUNDREDTHSOFMILLIMETERS
CdlPSDDisableMargins = PSD_DISABLEMARGINS
CdlPSDDisablePrinter = PSD_DISABLEPRINTER
CdlPSDNoWarning = PSD_NOWARNING
CdlPSDDisableOrientation = PSD_DISABLEORIENTATION
CdlPSDDisablePaper = PSD_DISABLEPAPER
CdlPSDReturnDefault = PSD_RETURNDEFAULT
CdlPSDHelpButton = PSD_SHOWHELP
CdlPSDDisablePagePainting = PSD_DISABLEPAGEPAINTING
CdlPSDNoNetworkButton = PSD_NONETWORKBUTTON
End Enum
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_DONTGOBELOWDOMAIN As Long = &H2
Private Const BIF_STATUSTEXT As Long = &H4
Private Const BIF_RETURNFSANCESTORS As Long = &H8
Private Const BIF_EDITBOX As Long = &H10
Private Const BIF_VALIDATE As Long = &H20
Private Const BIF_NEWDIALOGSTYLE As Long = &H40
Private Const BIF_BROWSEINCLUDEURLS As Long = &H80
Private Const BIF_USENEWUI As Long = BIF_EDITBOX Or BIF_NEWDIALOGSTYLE
Private Const BIF_UAHINT As Long = &H100
Private Const BIF_NONEWFOLDERBUTTON As Long = &H200
Private Const BIF_NOTRANSLATETARGETS As Long = &H400
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000
Private Const BIF_BROWSEFORPRINTER As Long = &H2000
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const BIF_SHAREABLE As Long = &H8000&
Private Const BIF_BROWSEFILEJUNCTIONS As Long = &H10000
Public Enum CdlBIFConstants
CdlBIFReturnOnlyFSDirs = BIF_RETURNONLYFSDIRS
CdlBIFDontGoBelowDomain = BIF_DONTGOBELOWDOMAIN
CdlBIFStatusText = BIF_STATUSTEXT
CdlBIFReturnFSAncestors = BIF_RETURNFSANCESTORS
CdlBIFEditBox = BIF_EDITBOX
CdlBIFValidate = BIF_VALIDATE
CdlBIFNewDialogStyle = BIF_NEWDIALOGSTYLE
CdlBIFBrowseIncludeURLs = BIF_BROWSEINCLUDEURLS
CdlBIFUseNewUI = BIF_USENEWUI
CdlBIFUAHint = BIF_UAHINT
CdlBIFNoNewFolderButton = BIF_NONEWFOLDERBUTTON
CdlBIFNoTranslateTargets = BIF_NOTRANSLATETARGETS
CdlBIFBrowseForComputer = BIF_BROWSEFORCOMPUTER
CdlBIFBrowseForPrinter = BIF_BROWSEFORPRINTER
CdlBIFBrowseIncludeFiles = BIF_BROWSEINCLUDEFILES
CdlBIFShareable = BIF_SHAREABLE
CdlBIFBrowseFileJunctions = BIF_BROWSEFILEJUNCTIONS
End Enum
Private Const FR_DOWN As Long = &H1
Private Const FR_WHOLEWORD As Long = &H2
Private Const FR_MATCHCASE As Long = &H4
Private Const FR_FINDNEXT As Long = &H8
Private Const FR_REPLACE As Long = &H10
Private Const FR_REPLACEALL As Long = &H20
Private Const FR_DIALOGTERM As Long = &H40 ' Internal use only
Private Const FR_SHOWHELP As Long = &H80
Private Const FR_ENABLEHOOK As Long = &H100 ' Internal use only
Private Const FR_NOUPDOWN As Long = &H400
Private Const FR_NOMATCHCASE As Long = &H800
Private Const FR_NOWHOLEWORD As Long = &H1000
Private Const FR_HIDEUPDOWN As Long = &H4000
Private Const FR_HIDEMATCHCASE As Long = &H8000
Private Const FR_HIDEWHOLEWORD As Long = &H10000
Public Enum CdlFRConstants
CdlFRDown = FR_DOWN
CdlFRWholeWord = FR_WHOLEWORD
CdlFRMatchCase = FR_MATCHCASE
CdlFRFindNext = FR_FINDNEXT
CdlFRReplace = FR_REPLACE
CdlFRReplaceAll = FR_REPLACEALL
CdlFRHelpButton = FR_SHOWHELP
CdlFRNoUpDown = FR_NOUPDOWN
CdlFRNoMatchCase = FR_NOMATCHCASE
CdlFRNoWholeWord = FR_NOWHOLEWORD
CdlFRHideUpDown = FR_HIDEUPDOWN
CdlFRHideMatchCase = FR_HIDEMATCHCASE
CdlFRHideWholeWord = FR_HIDEWHOLEWORD
End Enum
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type OPENFILENAME
lStructSize As Long
hWndOwner As Long
hInstance As Long
lpstrFilter As Long
lpstrCustomFilter As Long
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As Long
nMaxFile As Long
lpstrFileTitle As Long
nMaxFileTitle As Long
lpstrInitialDir As Long
lpstrTitle As Long
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
pvReserved As Long
dwReserved As Long
FlagsEx As Long
End Type
Private Type TCHOOSECOLOR
lStructSize As Long
hWndOwner As Long
hInstance As Long
RGBResult As Long
lpCustColors As Long
Flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
Private Type TCHOOSEFONT
lStructSize As Long
hWndOwner As Long
hDC As Long
lpLogFont As Long
iPointSize As Long
Flags As Long
RGBColor As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
hInstance As Long
lpszStyle As Long
nFontType As Integer
nSizeMin As Long
nSizeMax As Long
End Type
Private Const LF_FACESIZE As Long = 32
Private Const FW_NORMAL As Long = 400
Private Const FW_BOLD As Long = 700
Private Const DEFAULT_QUALITY As Long = 0
Private 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(0 To ((LF_FACESIZE * 2) - 1)) As Byte
End Type
Private Type PRINTDLG
lStructSize As Long
hWndOwner As Long
hDevMode As Long
hDevNames As Long
hDC As Long
Flags As Long
nFromPage As Integer
nToPage As Integer
nMinPage As Integer
nMaxPage As Integer
nCopies As Integer
hInstanceLo As Integer
hInstanceHi As Integer
lCustDataLo As Integer
lCustDataHi As Integer
lpfnPrintHookLo As Integer
lpfnPrintHookHi As Integer
lpfnSetupHookLo As Integer
lpfnSetupHookHi As Integer
lpPrintTemplateNameLo As Integer
lpPrintTemplateNameHi As Integer
lpSetupTemplateNameLo As Integer
lpSetupTemplateNameHi As Integer
hPrintTemplateLo As Integer
hPrintTemplateHi As Integer
hSetupTemplateLo As Integer
hSetupTemplateHi As Integer
End Type
Private Type PRINTPAGERANGE
nFromPage As Long
nToPage As Long
End Type
Private Type PRINTDLGEX
lStructSize As Long
hWndOwner As Long
hDevMode As Long
hDevNames As Long
hDC As Long
Flags As Long
Flags2 As Long
ExclusionFlags As Long
nPageRanges As Long
nMaxPageRanges As Long
lpPageRanges As Long
nMinPage As Long
nMaxPage As Long
nCopies As Long
hInstance As Long
lpPrintTemplateName As Long
lpCallback As Long
nPropertyPages As Long
lphPropertyPages As Long
nStartPage As Long
dwResultAction As Long
End Type
Private Type PAGESETUPDLG
lStructSize As Long
hWndOwner As Long
hDevMode As Long
hDevNames As Long
Flags As Long
PTPaperSize As POINTAPI
RCMinMargin As RECT
RCMargin As RECT
hInstance As Long
lCustData As Long
lpfnPageSetupHook As Long
lpfnPagePaintHook As Long
lpPageSetupTemplateName As Long
hPageSetupTemplate As Long
End Type
Private Const CCHDEVNAMESEXTRA As Long = 100
Private Const DN_DEFAULTPRN As Long = 1
Private Type DEVNAMES
wDriverOffset As Integer
wDeviceOffset As Integer
wOutputOffset As Integer
wDefault As Integer
wExtra(0 To ((CCHDEVNAMESEXTRA * 2) - 1)) As Byte
End Type
Private Const CCHDEVICENAME As Long = 32
Private Const CCHFORMNAME As Long = 32
Private Const DM_ORIENTATION As Long = &H1
Private Const DM_PAPERSIZE As Long = &H2
Private Const DM_COPIES As Long = &H100
Private Const DM_DEFAULTSOURCE As Long = &H200
Private Const DM_PRINTQUALITY As Long = &H400
Private Const DM_COLOR As Long = &H800
Private Const DM_DUPLEX As Long = &H1000
Private Const DM_COLLATE As Long = &H8000&
Private Type DEVMODE
DMDeviceName(0 To ((CCHDEVICENAME * 2) - 1)) As Byte
DMSpecVersion As Integer
DMDriverVersion As Integer
DMSize As Integer
DMDriverExtra As Integer
DMFields As Long
DMOrientation As Integer
DMPaperSize As Integer
DMPaperLength As Integer
DMPaperWidth As Integer
DMScale As Integer
DMCopies As Integer
DMDefaultSource As Integer
DMPrintQuality As Integer
DMColor As Integer
DMDuplex As Integer
DMYResolution As Integer
DMTTOption As Integer
DMCollate As Integer
DMFormName(0 To ((CCHFORMNAME * 2) - 1)) As Byte
DMLogPixels As Integer
DMBitsPerPel As Long
DMPelsWidth As Long
DMPelsHeight As Long
DMDisplayFlags As Long
DMDisplayFrequency As Long
DMICMMethod As Long
DMICMIntent As Long
DMMediaType As Long
DMDitherType As Long
DMReserved1 As Long
DMReserved2 As Long
DMPanningWidth As Long
DMPanningHeight As Long
End Type
Private Type BROWSEINFO
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Type FINDREPLACE
lStructSize As Long
hWndOwner As Long
hInstance As Long
Flags As Long
lpstrFindWhat As Long
lpstrReplaceWith As Long
wFindWhatLen As Integer
wReplaceWithLen As Integer
lCustData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
Private Type NMHDR
hWndFrom As Long
IDFrom As Long
Code As Long
End Type
Private Type NMOFNOTIFY
hdr As NMHDR
lpOFN As Long
lpszFileShareVi As Long
End Type
Public Event InitDialog(ByVal Action As Integer, ByVal hDlg As Long)
Public Event Help(ByRef Handled As Boolean, ByVal Action As Integer, ByVal hDlg As Long)
Public Event FileShareViolation(ByVal FileName As String, ByRef Result As CdlOFNShareViResultConstants, ByVal hDlg As Long)
Public Event FileValidate(ByVal FileName As String, ByVal FileTitle As String, ByVal FileOffset As Integer, ByRef Cancel As Boolean, ByVal hDlg As Long)
Public Event ColorValidate(ByRef RGBColor As Long, ByRef Cancel As Boolean, ByVal hDlg As Long)
Public Event FontApply(ByVal Flags As Long, ByVal FontName As String, ByVal FontSize As Single, ByVal FontBold As Boolean, ByVal FontItalic As Boolean, ByVal FontStrikethru As Boolean, ByVal FontUnderline As Boolean, ByVal FontCharset As Integer, ByVal RGBColor As Long, ByVal hDlg As Long)
Public Event FolderBrowserValidateFailed(ByVal Text As String, ByRef Cancel As Boolean, ByVal hDlg As Long)
Public Event FindNext()
Public Event Replace()
Public Event ReplaceAll()
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal hMem As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function CommDlgExtendedError Lib "comdlg32" () As Long
Private Declare Function GetOpenFileName Lib "comdlg32" Alias "GetOpenFileNameW" (ByRef lpOpenFileName As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32" Alias "GetSaveFileNameW" (ByRef lpOpenFileName As OPENFILENAME) As Long
Private Declare Function ChooseColor Lib "comdlg32" Alias "ChooseColorW" (ByRef lpChooseColor As TCHOOSECOLOR) As Long
Private Declare Function ChooseFont Lib "comdlg32" Alias "ChooseFontW" (ByRef lpChooseFont As TCHOOSEFONT) As Long
Private Declare Function WinHelp Lib "user32" Alias "WinHelpW" (ByVal hwnd As Long, ByVal lpHelpFile As Long, ByVal wCommand As Long, ByVal dwData As Long) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExW" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpszClass As Long, ByVal lpszWindow As Long) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" Alias "SHBrowseForFolderW" (ByRef lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetFolderLocation Lib "shell32" (ByVal hWndOwner As Long, ByVal nFolder As Long, ByVal hToken As Long, ByVal dwReserved As Long, ByRef lpIDList As Long) As Long
Private Declare Function ILCreateFromPath Lib "shell32" (ByVal lpszPath As Long) As Long
Private Declare Function ILCreateFromPath_W2K Lib "shell32" Alias "#157" (ByVal lpszPath As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDListW" (ByVal lpIDList As Long, ByVal lpBuffer As Long) As Long
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageW" (ByVal lpString As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageW" (ByVal hDlg As Long, ByVal nIDDlgItem As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoW" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As Long, ByVal cchData As Long) As Long
Private Declare Function PrintDialog Lib "comdlg32" Alias "PrintDlgW" (ByRef lpPrintDlg As PRINTDLG) As Long
Private Declare Function PrintDialogEx Lib "comdlg32" Alias "PrintDlgExW" (ByRef lpPrintDlgEx As PRINTDLGEX) As Long
Private Declare Function PageSetupDialog Lib "comdlg32" Alias "PageSetupDlgW" (ByRef lpPageSetupDlg As PAGESETUPDLG) As Long
Private Declare Function GetDefaultPrinter Lib "winspool.drv" Alias "GetDefaultPrinterW" (ByVal lpszPrinterName As Long, ByRef cch As Long) As Long
Private Declare Function SetDefaultPrinter Lib "winspool.drv" Alias "SetDefaultPrinterW" (ByVal lpszPrinterName As Long) As Long
Private Declare Function FindText Lib "comdlg32" Alias "FindTextW" (ByRef lpFindReplace As FINDREPLACE) As Long
Private Declare Function ReplaceText Lib "comdlg32" Alias "ReplaceTextW" (ByRef lpFindReplace As FINDREPLACE) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Const HELPMSGSTRING As String = "commdlg_help"
Private Const SHAREVISTRING As String = "commdlg_ShareViolation"
Private Const FILEOKSTRING As String = "commdlg_FileNameOK"
Private Const COLOROKSTRING As String = "commdlg_ColorOK"
Private Const SETRGBSTRING As String = "commdlg_SetRGBColor"
Private Const FINDMSGSTRING As String = "commdlg_FindReplace"
Private Const WM_INITDIALOG As Long = &H110
Private Const WM_COMMAND As Long = &H111
Private Const WM_NOTIFY As Long = &H4E
Private Const WM_USER As Long = &H400
Private Const BN_CLICKED As Long = 0
Private Const DWL_MSGRESULT As Long = 0
Private Const GMEM_MOVEABLE As Long = &H2
Private Const GMEM_ZEROINIT As Long = &H40
Private Const MAXINT_2 As Integer = 32767
Private Const MAX_PATH As Long = 260
Private Const S_OK As Long = &H0
Implements ISubclass
Private CommonDialogHelpMsg As Long
Private CommonDialogShareViMsg As Long
Private CommonDialogFileOKMsg As Long
Private CommonDialogColorOKMsg As Long
Private CommonDialogSetRGBMsg As Long
Private CommonDialogFindMsg As Long
Private CommonDialogFR As FINDREPLACE
Private CommonDialogFRDialogHandle As Long
Private CommonDialogFRBufferFindWhat As String
Private CommonDialogFRBufferReplaceWith As String
Private CommonDialogDMFieldsExclusion As Long
Private PropCancelError As Boolean
Private PropHookEvents As Boolean
Private PropTag As String
Private PropDC As Long
Private PropFlags As Long
Private PropDialogTitle As String
Private PropMaxFileSize As Long
Private PropFileName As String, PropFileTitle As String
Private PropFileOffset As Integer
Private PropFilter As String, PropFilterIndex As Long
Private PropInitDir As String
Private PropDefaultExt As String
Private PropColor As Long
Private PropFontName As String, PropFontSize As Single, PropFontBold As Boolean, PropFontItalic As Boolean, PropFontStrikethru As Boolean, PropFontUnderline As Boolean, PropFontCharset As Integer
Private PropMin As Long, PropMax As Long
Private PropFromPage As Long, PropToPage As Long
Private PropOrientation As CdlPRORConstants
Private PropPaperSize As CdlPRPSConstants
Private PropCopies As Integer
Private PropPaperBin As CdlPRBNConstants
Private PropPrintQuality As CdlPRPQConstants
Private PropColorMode As CdlPRCMConstants
Private PropDuplex As CdlPRDPConstants
Private PropPrinterDefault As Boolean, PropPrinterDefaultInit As Boolean
Private PropPrinterDriver As String, PropPrinterName As String, PropPrinterPort As String
Private PropHelpFile As String
Private PropHelpCommand As CdlHelpConstants
Private PropHelpContext As Long
Private PropHelpKey As String
Private PropPageLeftMargin As Long, PropPageTopMargin As Long, PropPageRightMargin As Long, PropPageBottomMargin As Long
Private PropPageLeftMinMargin As Long, PropPageTopMinMargin As Long, PropPageRightMinMargin As Long, PropPageBottomMinMargin As Long
Private PropRootFolder As Variant
Private PropFindWhat As String
Private PropReplaceWith As String
Private Sub Class_Initialize()
Const LOCALE_IMEASURE As Long = &HD, LOCALE_RETURN_NUMBER As Long = &H20000000
Dim LocaleMeasure As Long
GetLocaleInfo 0, LOCALE_IMEASURE Or LOCALE_RETURN_NUMBER, VarPtr(LocaleMeasure), LenB(LocaleMeasure)
CommonDialogDMFieldsExclusion = DM_ORIENTATION Or DM_PAPERSIZE Or DM_DEFAULTSOURCE Or DM_PRINTQUALITY Or DM_COLOR Or DM_DUPLEX
PropMaxFileSize = MAX_PATH
PropFontSize = 8
PropOrientation = CdlPRORPortrait
PropPaperSize = IIf(LocaleMeasure = 0, CdlPRPSA4, CdlPRPSLetter)
PropCopies = 1
PropPaperBin = CdlPRBNAuto
PropPrintQuality = CdlPRPQHigh
PropColorMode = CdlPRCMColor
PropDuplex = CdlPRDPSimplex
PropPrinterDefault = True
PropPrinterDefaultInit = True
End Sub
Private Sub Class_Terminate()
If PropDC <> 0 Then DeleteObject PropDC
If CommonDialogFRDialogHandle <> 0 Then
If IsWindow(CommonDialogFRDialogHandle) = 0 Then
Call ComCtlsCdlFRReleaseHook(CommonDialogFRDialogHandle)
Else
Const WM_CLOSE As Long = &H10
SendMessage CommonDialogFRDialogHandle, WM_CLOSE, 0, ByVal 0&
DoEvents
End If
End If
End Sub
Public Property Get Object() As Object
Set Object = Me
End Property
Public Property Get CancelError() As Boolean
CancelError = PropCancelError
End Property
Public Property Let CancelError(ByVal Value As Boolean)
PropCancelError = Value
End Property
Public Property Get HookEvents() As Boolean
HookEvents = PropHookEvents
End Property
Public Property Let HookEvents(ByVal Value As Boolean)
PropHookEvents = Value
End Property
Public Property Get Tag() As String
Tag = PropTag
End Property
Public Property Let Tag(ByVal Value As String)
PropTag = Value
End Property
Public Property Get hDC() As Long
hDC = PropDC
End Property
Public Property Let hDC(ByVal Value As Long)
ERR.Raise Number:=383, Description:="Property is read-only"
End Property
Public Property Get Flags() As Long
Flags = PropFlags
End Property
Public Property Let Flags(ByVal Value As Long)
PropFlags = Value
End Property
Public Property Get DialogTitle() As String
DialogTitle = PropDialogTitle
End Property
Public Property Let DialogTitle(ByVal Value As String)
PropDialogTitle = Value
End Property
Public Property Get MaxFileSize() As Long
MaxFileSize = PropMaxFileSize
End Property
Public Property Let MaxFileSize(ByVal Value As Long)
If Value < 1 Then ERR.Raise 380
PropMaxFileSize = Value
End Property
Public Property Get FileName() As String
FileName = PropFileName
End Property
Public Property Let FileName(ByVal Value As String)
PropFileName = Value
End Property
Public Property Get FileTitle() As String
FileTitle = PropFileTitle
End Property
Public Property Let FileTitle(ByVal Value As String)
ERR.Raise Number:=383, Description:="Property is read-only"
End Property
Public Property Get FileOffset() As Integer
FileOffset = PropFileOffset
End Property
Public Property Let FileOffset(ByVal Value As Integer)
ERR.Raise Number:=383, Description:="Property is read-only"
End Property
Public Property Get Filter() As String
Filter = PropFilter
End Property
Public Property Let Filter(ByVal Value As String)
PropFilter = Value
End Property
Public Property Get FilterIndex() As Long
FilterIndex = PropFilterIndex
End Property
Public Property Let FilterIndex(ByVal Value As Long)
If Value < 0 Then ERR.Raise 380
PropFilterIndex = Value
End Property
Public Property Get InitDir() As String
InitDir = PropInitDir
End Property
Public Property Let InitDir(ByVal Value As String)
PropInitDir = Value
End Property
Public Property Get DefaultExt() As String
DefaultExt = PropDefaultExt
End Property
Public Property Let DefaultExt(ByVal Value As String)
PropDefaultExt = Value
End Property
Public Property Get Color() As Long
Color = PropColor
End Property
Public Property Let Color(ByVal Value As Long)
PropColor = Value
End Property
Public Property Get FontName() As String
FontName = PropFontName
End Property
Public Property Let FontName(ByVal Value As String)
PropFontName = Value
End Property
Public Property Get FontSize() As Single
FontSize = PropFontSize
End Property
Public Property Let FontSize(ByVal Value As Single)
PropFontSize = Value
End Property
Public Property Get FontBold() As Boolean
FontBold = PropFontBold
End Property
Public Property Let FontBold(ByVal Value As Boolean)
PropFontBold = Value
End Property
Public Property Get FontItalic() As Boolean
FontItalic = PropFontItalic
End Property
Public Property Let FontItalic(ByVal Value As Boolean)
PropFontItalic = Value
End Property
Public Property Get FontStrikethru() As Boolean
FontStrikethru = PropFontStrikethru
End Property
Public Property Let FontStrikethru(ByVal Value As Boolean)
PropFontStrikethru = Value
End Property
Public Property Get FontUnderline() As Boolean
FontUnderline = PropFontUnderline
End Property
Public Property Let FontUnderline(ByVal Value As Boolean)
PropFontUnderline = Value
End Property
Public Property Get FontCharset() As Integer
FontCharset = PropFontCharset
End Property
Public Property Let FontCharset(ByVal Value As Integer)
PropFontCharset = Value
End Property
Public Property Get Min() As Long
Min = PropMin
End Property
Public Property Let Min(ByVal Value As Long)
If Value < 0 Then ERR.Raise 380
PropMin = Value
End Property
Public Property Get Max() As Long
Max = PropMax
End Property
Public Property Let Max(ByVal Value As Long)
If Value < 0 Then ERR.Raise 380
PropMax = Value
End Property
Public Property Get FromPage() As Long
FromPage = PropFromPage
End Property
Public Property Let FromPage(ByVal Value As Long)
If Value < 0 Then ERR.Raise 380
PropFromPage = Value
End Property
Public Property Get ToPage() As Long
ToPage = PropToPage
End Property
Public Property Let ToPage(ByVal Value As Long)
If Value < 0 Then ERR.Raise 380
PropToPage = Value
End Property
Public Property Get Orientation() As CdlPRORConstants
Orientation = PropOrientation
End Property
Public Property Let Orientation(ByVal Value As CdlPRORConstants)
Select Case Value
Case CdlPRORPortrait, CdlPRORLandscape
PropOrientation = Value
Case Else
ERR.Raise 380
End Select
If (CommonDialogDMFieldsExclusion And DM_ORIENTATION) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_ORIENTATION
End Property
Public Property Get PaperSize() As CdlPRPSConstants
PaperSize = PropPaperSize
End Property
Public Property Let PaperSize(ByVal Value As CdlPRPSConstants)
Select Case Value
Case 1 To MAXINT_2
PropPaperSize = Value
Case Else
ERR.Raise 380
End Select
If (CommonDialogDMFieldsExclusion And DM_PAPERSIZE) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_PAPERSIZE
End Property
Public Property Get Copies() As Integer
Copies = PropCopies
End Property
Public Property Let Copies(ByVal Value As Integer)
If Value < 1 Then ERR.Raise 380
PropCopies = Value
End Property
Public Property Get PaperBin() As CdlPRBNConstants
PaperBin = PropPaperBin
End Property
Public Property Let PaperBin(ByVal Value As CdlPRBNConstants)
Select Case Value
Case 1 To MAXINT_2
PropPaperBin = Value
Case Else
ERR.Raise 380
End Select
If (CommonDialogDMFieldsExclusion And DM_DEFAULTSOURCE) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_DEFAULTSOURCE
End Property
Public Property Get PrintQuality() As CdlPRPQConstants
PrintQuality = PropPrintQuality
End Property
Public Property Let PrintQuality(ByVal Value As CdlPRPQConstants)
Select Case Value
Case CdlPRPQHigh, CdlPRPQMedium, CdlPRPQLow, CdlPRPQDraft, 0 To MAXINT_2
PropPrintQuality = Value
Case Else
ERR.Raise 380
End Select
If (CommonDialogDMFieldsExclusion And DM_PRINTQUALITY) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_PRINTQUALITY
End Property
Public Property Get ColorMode() As CdlPRCMConstants
ColorMode = PropColorMode
End Property
Public Property Let ColorMode(ByVal Value As CdlPRCMConstants)
Select Case Value
Case CdlPRCMMonochrome, CdlPRCMColor
PropColorMode = Value
Case Else
ERR.Raise 380
End Select
If (CommonDialogDMFieldsExclusion And DM_COLOR) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_COLOR
End Property
Public Property Get Duplex() As CdlPRDPConstants
Duplex = PropDuplex
End Property
Public Property Let Duplex(ByVal Value As CdlPRDPConstants)
Select Case Value
Case CdlPRDPSimplex, CdlPRDPHorizontal, CdlPRDPVertical
PropDuplex = Value
Case Else
ERR.Raise 380
End Select
If (CommonDialogDMFieldsExclusion And DM_DUPLEX) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_DUPLEX
End Property
Public Property Get PrinterDefault() As Boolean
PrinterDefault = PropPrinterDefault
End Property
Public Property Let PrinterDefault(ByVal Value As Boolean)
PropPrinterDefault = Value
End Property
Public Property Get PrinterDefaultInit() As Boolean
PrinterDefaultInit = PropPrinterDefaultInit
End Property
Public Property Let PrinterDefaultInit(ByVal Value As Boolean)
PropPrinterDefaultInit = Value
End Property
Public Property Get PrinterDriver() As String
PrinterDriver = PropPrinterDriver
End Property
Public Property Let PrinterDriver(ByVal Value As String)
PropPrinterDriver = Value
End Property
Public Property Get PrinterName() As String
PrinterName = PropPrinterName
End Property
Public Property Let PrinterName(ByVal Value As String)
PropPrinterName = Value
End Property
Public Property Get PrinterPort() As String
PrinterPort = PropPrinterPort
End Property
Public Property Let PrinterPort(ByVal Value As String)
PropPrinterPort = Value
End Property
Public Property Get HelpFile() As String
HelpFile = PropHelpFile
End Property
Public Property Let HelpFile(ByVal Value As String)
PropHelpFile = Value
End Property
Public Property Get HelpCommand() As CdlHelpConstants
HelpCommand = PropHelpCommand
End Property
Public Property Let HelpCommand(ByVal Value As CdlHelpConstants)
Select Case Value
Case 0, CdlHelpContext, CdlHelpQuit, CdlHelpIndex, CdlHelpContents, CdlHelpHelpOnHelp, CdlHelpSetIndex, CdlHelpSetContents, CdlHelpContextPopup, CdlHelpForceFile, CdlHelpKey, CdlHelpCommandHelp, CdlHelpPartialKey
PropHelpCommand = Value
Case Else
ERR.Raise 380
End Select
End Property
Public Property Get HelpContext() As Long
HelpContext = PropHelpContext
End Property
Public Property Let HelpContext(ByVal Value As Long)
PropHelpContext = Value
End Property
Public Property Get HelpKey() As String
HelpKey = PropHelpKey
End Property
Public Property Let HelpKey(ByVal Value As String)
PropHelpKey = Value
End Property
Public Property Get PageLeftMargin() As Long
PageLeftMargin = PropPageLeftMargin
End Property
Public Property Let PageLeftMargin(ByVal Value As Long)
If Value < 0 Then ERR.Raise 380
PropPageLeftMargin = Value
End Property
Public Property Get PageTopMargin() As Long
PageTopMargin = PropPageTopMargin
End Property
Public Property Let PageTopMargin(ByVal Value As Long)
If Value < 0 Then ERR.Raise 380
PropPageTopMargin = Value
End Property
Public Property Get PageRightMargin() As Long
PageRightMargin = PropPageRightMargin
End Property
Public Property Let PageRightMargin(ByVal Value As Long)
If Value < 0 Then ERR.Raise 380
PropPageRightMargin = Value
End Property
Public Property Get PageBottomMargin() As Long
PageBottomMargin = PropPageBottomMargin
End Property
Public Property Let PageBottomMargin(ByVal Value As Long)
If Value < 0 Then ERR.Raise 380
PropPageBottomMargin = Value
End Property
Public Property Get PageLeftMinMargin() As Long
PageLeftMinMargin = PropPageLeftMinMargin
End Property
Public Property Let PageLeftMinMargin(ByVal Value As Long)
If Value < 0 Then ERR.Raise 380
PropPageLeftMinMargin = Value
End Property
Public Property Get PageTopMinMargin() As Long
PageTopMinMargin = PropPageTopMinMargin
End Property
Public Property Let PageTopMinMargin(ByVal Value As Long)
If Value < 0 Then ERR.Raise 380
PropPageTopMinMargin = Value
End Property
Public Property Get PageRightMinMargin() As Long
PageRightMinMargin = PropPageRightMinMargin
End Property
Public Property Let PageRightMinMargin(ByVal Value As Long)
If Value < 0 Then ERR.Raise 380
PropPageRightMinMargin = Value
End Property
Public Property Get PageBottomMinMargin() As Long
PageBottomMinMargin = PropPageBottomMinMargin
End Property
Public Property Let PageBottomMinMargin(ByVal Value As Long)
If Value < 0 Then ERR.Raise 380
PropPageBottomMinMargin = Value
End Property
Public Property Get RootFolder() As Variant
RootFolder = PropRootFolder
End Property
Public Property Let RootFolder(ByVal Value As Variant)
Select Case VarType(Value)
Case vbEmpty, vbLong, vbInteger, vbByte, vbString, vbDouble, vbSingle
PropRootFolder = Value
Case Else
ERR.Raise 380
End Select
End Property
Public Property Get FindWhat() As String
FindWhat = PropFindWhat
End Property
Public Property Let FindWhat(ByVal Value As String)
PropFindWhat = Value
End Property
Public Property Get ReplaceWith() As String
ReplaceWith = PropReplaceWith
End Property
Public Property Let ReplaceWith(ByVal Value As String)
PropReplaceWith = Value
End Property
Public Property Get Action() As Integer
ERR.Raise Number:=394, Description:="Property is write-only"
End Property
Public Property Let Action(ByVal Value As Integer)
Select Case Value
Case 1
Me.ShowOpen
Case 2
Me.ShowSave
Case 3
Me.ShowColor
Case 4
Me.ShowFont
Case 5
Me.ShowPrinter
Case 6
Me.ShowHelp
Case 7
Me.ShowPageSetup
Case 8
Me.ShowFolderBrowser
Case 9
Me.ShowFind
Case 10
Me.ShowReplace
Case Else
ERR.Raise 380
End Select
End Property
Public Function ShowOpen() As Boolean
Dim Buffer As String, Filter As String
Buffer = String(PropMaxFileSize, vbNullChar)
Dim OFN As OPENFILENAME
With OFN
.lStructSize = LenB(OFN)
.hWndOwner = GetOwnerWindow()
.hInstance = App.hInstance
Filter = ProperFilter(PropFilter)
.lpstrFilter = StrPtr(Filter)
.nFilterIndex = PropFilterIndex
If Not PropFileName = vbNullString Then Mid$(Buffer, 1, Len(PropFileName)) = PropFileName
.lpstrFile = StrPtr(Buffer)
.nMaxFile = Len(Buffer)
.lpstrInitialDir = StrPtr(PropInitDir)
.lpstrTitle = StrPtr(PropDialogTitle)
If PropHookEvents = False Then
.Flags = PropFlags
Else
.Flags = (OFN_ENABLEHOOK Or OFN_ENABLESIZING) Or PropFlags
If (PropFlags And CdlOFNExplorer) = CdlOFNExplorer Then
.lpfnHook = ProcPtr(AddressOf ComCtlsCdlOFN1CallbackProc)
Else
.lpfnHook = ProcPtr(AddressOf ComCtlsCdlOFN1CallbackProcOldStyle)
End If
Dim This As ISubclass
Set This = Me
.lCustData = ObjPtr(This)
End If
End With
Dim RetVal As Long
If (PropFlags And CdlOFNHelpButton) = CdlOFNHelpButton Then
If CommonDialogHelpMsg = 0 Then CommonDialogHelpMsg = RegisterWindowMessage(StrPtr(HELPMSGSTRING))
Call ComCtlsSetSubclass(OFN.hWndOwner, Me, 1, HELPMSGSTRING & "_1")
RetVal = GetOpenFileName(OFN)
Call ComCtlsRemoveSubclass(OFN.hWndOwner, HELPMSGSTRING & "_1")
Else
RetVal = GetOpenFileName(OFN)
End If
If RetVal <> 0 Then
If (OFN.Flags And (OFN_ENABLEHOOK Or OFN_ENABLESIZING)) = 0 Then
PropFlags = OFN.Flags
Else
PropFlags = OFN.Flags And Not (OFN_ENABLEHOOK Or OFN_ENABLESIZING)
End If
If OFN.nFileOffset > 0 Then
If Mid$(Buffer, OFN.nFileOffset, 1) = vbNullChar Then
PropFileName = Left$(Buffer, InStr(Buffer & vbNullChar & vbNullChar, vbNullChar & vbNullChar) - 1)
PropFileTitle = vbNullString
Else
PropFileName = Left$(Buffer, InStr(Buffer & vbNullChar, vbNullChar) - 1)
PropFileTitle = Mid$(PropFileName, OFN.nFileOffset + 1)
End If
End If
PropFilterIndex = OFN.nFilterIndex
PropFileOffset = OFN.nFileOffset
ShowOpen = True
Else
Dim ErrVal As Long
ErrVal = CommDlgExtendedError()
Select Case ErrVal
Case FNERR_BUFFERTOOSMALL
ERR.Raise Number:=CdlBufferTooSmall, Description:="The buffer at which the member LpstrFile points is too small."
Case FNERR_INVALIDFILENAME
ERR.Raise Number:=CdlInvalidFileName, Description:="File name is invalid."
Case FNERR_SUBCLASSFAILURE
ERR.Raise Number:=CdlSubclassFailure, Description:="An attempt to subclass a listbox failed due to insufficient memory."
Case 0
If PropCancelError = True Then ERR.Raise Number:=CdlCancel, Description:="Cancel was selected."
Case Else
ERR.Raise Number:=ErrVal, Description:="Unexpected error."
End Select
End If
End Function
Public Function ShowSave() As Boolean
Dim Buffer As String, Filter As String, DefaultExt As String
Buffer = String(PropMaxFileSize, vbNullChar)
Dim OFN As OPENFILENAME
With OFN
.lStructSize = LenB(OFN)
.hWndOwner = GetOwnerWindow()
.hInstance = App.hInstance
Filter = ProperFilter(PropFilter)
.lpstrFilter = StrPtr(Filter)
.nFilterIndex = PropFilterIndex
If Not PropFileName = vbNullString Then Mid$(Buffer, 1, Len(PropFileName)) = PropFileName
.lpstrFile = StrPtr(Buffer)
.nMaxFile = Len(Buffer)
.lpstrInitialDir = StrPtr(PropInitDir)
.lpstrTitle = StrPtr(PropDialogTitle)
If PropHookEvents = False Then
.Flags = PropFlags
Else
.Flags = (OFN_ENABLEHOOK Or OFN_ENABLESIZING) Or PropFlags
If (PropFlags And CdlOFNExplorer) = CdlOFNExplorer Then
.lpfnHook = ProcPtr(AddressOf ComCtlsCdlOFN2CallbackProc)
Else
.lpfnHook = ProcPtr(AddressOf ComCtlsCdlOFN2CallbackProcOldStyle)
End If
Dim This As ISubclass
Set This = Me
.lCustData = ObjPtr(This)
End If
If PropDefaultExt = vbNullString Then DefaultExt = vbNullChar Else DefaultExt = PropDefaultExt
.lpstrDefExt = StrPtr(DefaultExt)
End With
Dim RetVal As Long
If (PropFlags And CdlOFNHelpButton) = CdlOFNHelpButton Then
If CommonDialogHelpMsg = 0 Then CommonDialogHelpMsg = RegisterWindowMessage(StrPtr(HELPMSGSTRING))
Call ComCtlsSetSubclass(OFN.hWndOwner, Me, 2, HELPMSGSTRING & "_2")
RetVal = GetSaveFileName(OFN)
Call ComCtlsRemoveSubclass(OFN.hWndOwner, HELPMSGSTRING & "_2")
Else
RetVal = GetSaveFileName(OFN)
End If
If RetVal <> 0 Then
If (OFN.Flags And (OFN_ENABLEHOOK Or OFN_ENABLESIZING)) = 0 Then
PropFlags = OFN.Flags
Else
PropFlags = OFN.Flags And Not (OFN_ENABLEHOOK Or OFN_ENABLESIZING)
End If
If OFN.nFileOffset > 0 Then
If Mid$(Buffer, OFN.nFileOffset, 1) = vbNullChar Then
PropFileName = Left$(Buffer, InStr(Buffer & vbNullChar & vbNullChar, vbNullChar & vbNullChar) - 1)
PropFileTitle = vbNullString
Else
PropFileName = Left$(Buffer, InStr(Buffer & vbNullChar, vbNullChar) - 1)
PropFileTitle = Mid$(PropFileName, OFN.nFileOffset + 1)
End If
End If
PropFilterIndex = OFN.nFilterIndex
PropFileOffset = OFN.nFileOffset
ShowSave = True
Else
Dim ErrVal As Long
ErrVal = CommDlgExtendedError()
Select Case ErrVal
Case FNERR_BUFFERTOOSMALL
ERR.Raise Number:=CdlBufferTooSmall, Description:="The buffer at which the member lpstrFile points is too small."
Case FNERR_INVALIDFILENAME
ERR.Raise Number:=CdlInvalidFileName, Description:="File name is invalid."
Case FNERR_SUBCLASSFAILURE
ERR.Raise Number:=CdlSubclassFailure, Description:="An attempt to subclass a list box failed due to insufficient memory."
Case 0
If PropCancelError = True Then ERR.Raise Number:=CdlCancel, Description:="Cancel was selected."
Case Else
ERR.Raise Number:=ErrVal, Description:="Unexpected error."
End Select
End If
End Function
' Example for Filter: "Text Files (*.txt)|*.txt|All Files (*.*)|*.*"
Private Function ProperFilter(ByVal Filter As String) As String
Dim i As Long, Sign As String, Temp As String
For i = 1 To Len(Filter)
Sign = Mid$(Filter, i, 1)
If Sign = "|" Then
Temp = Temp & vbNullChar
Else
Temp = Temp & Sign
End If
Next i
Do Until Right$(Temp, 2) = vbNullChar & vbNullChar
Temp = Temp & vbNullChar
Loop
ProperFilter = Temp
End Function
Public Function ShowColor() As Boolean
Static CustomColors(0 To 15) As Long, CustomColorsInitialized As Boolean
Dim CHCLR As TCHOOSECOLOR
With CHCLR
.lStructSize = LenB(CHCLR)
.hWndOwner = GetOwnerWindow()
.hInstance = App.hInstance
.RGBResult = WinColor(PropColor)
If PropHookEvents = False Then
.Flags = PropFlags
Else
.Flags = CC_ENABLEHOOK Or PropFlags
.lpfnHook = ProcPtr(AddressOf ComCtlsCdlCCCallbackProc)
Dim This As ISubclass
Set This = Me
.lCustData = ObjPtr(This)
End If
If CustomColorsInitialized = False Then
Dim i As Long, IntValue As Integer
For i = 0 To 15
IntValue = 255 - (i * 16)
CustomColors(i) = RGB(IntValue, IntValue, IntValue)
Next i
CustomColorsInitialized = True
End If
.lpCustColors = VarPtr(CustomColors(0))
End With
Dim RetVal As Long
If (PropFlags And CdlCCHelpButton) = CdlCCHelpButton Then
If CommonDialogHelpMsg = 0 Then CommonDialogHelpMsg = RegisterWindowMessage(StrPtr(HELPMSGSTRING))
Call ComCtlsSetSubclass(CHCLR.hWndOwner, Me, 3, HELPMSGSTRING & "_3")
RetVal = ChooseColor(CHCLR)
Call ComCtlsRemoveSubclass(CHCLR.hWndOwner, HELPMSGSTRING & "_3")
Else
RetVal = ChooseColor(CHCLR)
End If
If RetVal <> 0 Then
If (CHCLR.Flags And CC_ENABLEHOOK) = 0 Then
PropFlags = CHCLR.Flags
Else
PropFlags = CHCLR.Flags And Not CC_ENABLEHOOK
End If
PropColor = CHCLR.RGBResult
ShowColor = True
Else
Dim ErrVal As Long
ErrVal = CommDlgExtendedError()
Select Case ErrVal
Case 0
If PropCancelError = True Then ERR.Raise Number:=CdlCancel, Description:="Cancel was selected."
Case Else
ERR.Raise Number:=ErrVal, Description:="Unexpected error."
End Select
End If
End Function
Public Function ShowFont() As Boolean
Dim CHFONT As TCHOOSEFONT, LF As LOGFONT, FontName As String
With LF
FontName = Left$(PropFontName, LF_FACESIZE)
CopyMemory .LFFaceName(0), ByVal StrPtr(FontName), LenB(FontName)
.LFHeight = -MulDiv(CLng(PropFontSize), DPI_Y(), 72)
If PropFontBold = True Then .LFWeight = FW_BOLD Else .LFWeight = FW_NORMAL
.LFItalic = IIf(PropFontItalic = True, 1, 0)
.LFStrikeOut = IIf(PropFontStrikethru = True, 1, 0)
.LFUnderline = IIf(PropFontUnderline = True, 1, 0)
.LFQuality = DEFAULT_QUALITY
.LFCharset = CByte(PropFontCharset And &HFF)
End With
With CHFONT
.lStructSize = LenB(CHFONT)
.hWndOwner = GetOwnerWindow()
.lpLogFont = VarPtr(LF)
If PropHookEvents = False Then
.Flags = CF_INITTOLOGFONTSTRUCT Or PropFlags
Else
.Flags = (CF_INITTOLOGFONTSTRUCT Or CF_ENABLEHOOK) Or PropFlags
.lpfnHook = ProcPtr(AddressOf ComCtlsCdlCFCallbackProc)
Dim This As ISubclass
Set This = Me
.lCustData = ObjPtr(This)
End If
.RGBColor = WinColor(PropColor)
.nSizeMin = PropMin
.nSizeMax = PropMax
End With
Dim RetVal As Long
If (PropFlags And CdlCFHelpButton) = CdlCFHelpButton Then
If CommonDialogHelpMsg = 0 Then CommonDialogHelpMsg = RegisterWindowMessage(StrPtr(HELPMSGSTRING))
Call ComCtlsSetSubclass(CHFONT.hWndOwner, Me, 4, HELPMSGSTRING & "_4")
RetVal = ChooseFont(CHFONT)
Call ComCtlsRemoveSubclass(CHFONT.hWndOwner, HELPMSGSTRING & "_4")
Else
RetVal = ChooseFont(CHFONT)
End If
If RetVal <> 0 Then
With CHFONT
If (.Flags And CF_ENABLEHOOK) = 0 Then
PropFlags = .Flags And Not CF_INITTOLOGFONTSTRUCT
Else
PropFlags = .Flags And Not (CF_INITTOLOGFONTSTRUCT Or CF_ENABLEHOOK)
End If
If (.Flags And CF_NOFACESEL) = 0 Then PropFontName = Left$(LF.LFFaceName(), InStr(CStr(LF.LFFaceName()) & vbNullChar, vbNullChar) - 1)
If (.Flags And CF_NOSTYLESEL) = 0 Then
PropFontBold = CBool(LF.LFWeight = FW_BOLD)
PropFontItalic = CBool(LF.LFItalic <> 0)
End If
If (.Flags And CF_NOSIZESEL) = 0 Then PropFontSize = CSng(.iPointSize / 10)
If (.Flags And CF_EFFECTS) <> 0 Then
PropFontStrikethru = CBool(LF.LFStrikeOut <> 0)
PropFontUnderline = CBool(LF.LFUnderline <> 0)
PropColor = .RGBColor
End If
If (.Flags And CF_NOSCRIPTSEL) = 0 Then PropFontCharset = CInt(LF.LFCharset)
End With
ShowFont = True
Else
Dim ErrVal As Long
ErrVal = CommDlgExtendedError()
Select Case ErrVal
Case CFERR_MAXLESSTHANMIN
ERR.Raise Number:=CdlMaxLessThanMin, Description:="The size specified in the nSizeMax member is less than the size specified in the nSizeMin member."
Case CFERR_NOFONTS
ERR.Raise Number:=CdlNoFonts, Description:="No fonts exist."
Case 0
If PropCancelError = True Then ERR.Raise Number:=CdlCancel, Description:="Cancel was selected."
Case Else
ERR.Raise Number:=ErrVal, Description:="Unexpected error."
End Select
End If
End Function
Public Function ShowPrinter() As Boolean
Dim PDLG As PRINTDLG, DMODE As DEVMODE, DNAMES As DEVNAMES
Dim lpDevMode As Long, lpDevNames As Long, Buffer As String
With PDLG
.lStructSize = Len(PDLG) ' LenB() is not applicable due to padding bytes.
.hWndOwner = GetOwnerWindow()
If PropHookEvents = False Then
.Flags = PropFlags
Else
.Flags = (PD_ENABLEPRINTHOOK Or PD_ENABLESETUPHOOK) Or PropFlags
Dim DWord As Long
DWord = ProcPtr(AddressOf ComCtlsCdlPDCallbackProc)
.lpfnPrintHookLo = LoWord(DWord)
.lpfnPrintHookHi = HiWord(DWord)
.lpfnSetupHookLo = .lpfnPrintHookLo
.lpfnSetupHookHi = .lpfnPrintHookHi
Dim This As ISubclass
Set This = Me
DWord = ObjPtr(This)
.lCustDataLo = LoWord(DWord)
.lCustDataHi = HiWord(DWord)
End If
.nFromPage = CUIntToInt(PropFromPage And &HFFFF&)
.nToPage = CUIntToInt(PropToPage And &HFFFF&)
.nMinPage = CUIntToInt(PropMin And &HFFFF&)
.nMaxPage = CUIntToInt(PropMax And &HFFFF&)
.nCopies = PropCopies
End With
If (PDLG.Flags And CdlPDReturnDefault) = 0 Then
DMODE.DMSize = LenB(DMODE)
If PropPrinterDefaultInit = False And Not (PropPrinterDriver = vbNullString Or PropPrinterName = vbNullString Or PropPrinterPort = vbNullString) Then
Buffer = Left$(PropPrinterName, CCHDEVICENAME)
CopyMemory DMODE.DMDeviceName(0), ByVal StrPtr(Buffer), LenB(Buffer)
End If
DMODE.DMFields = DM_ORIENTATION Or DM_PAPERSIZE Or DM_COPIES Or DM_DEFAULTSOURCE Or DM_PRINTQUALITY Or DM_COLOR Or DM_DUPLEX Or DM_COLLATE
If (CommonDialogDMFieldsExclusion And DM_ORIENTATION) = 0 Then
DMODE.DMOrientation = PropOrientation
Else
DMODE.DMFields = DMODE.DMFields And Not DM_ORIENTATION
End If
If (CommonDialogDMFieldsExclusion And DM_PAPERSIZE) = 0 Then
DMODE.DMPaperSize = PropPaperSize
Else
DMODE.DMFields = DMODE.DMFields And Not DM_PAPERSIZE
End If
DMODE.DMCopies = PropCopies
If (CommonDialogDMFieldsExclusion And DM_DEFAULTSOURCE) = 0 Then
DMODE.DMDefaultSource = PropPaperBin
Else
DMODE.DMFields = DMODE.DMFields And Not DM_DEFAULTSOURCE
End If
If (CommonDialogDMFieldsExclusion And DM_PRINTQUALITY) = 0 Then
DMODE.DMPrintQuality = PropPrintQuality
Else
DMODE.DMFields = DMODE.DMFields And Not DM_PRINTQUALITY
End If
If (CommonDialogDMFieldsExclusion And DM_COLOR) = 0 Then
DMODE.DMColor = PropColorMode
Else
DMODE.DMFields = DMODE.DMFields And Not DM_COLOR
End If
If (CommonDialogDMFieldsExclusion And DM_DUPLEX) = 0 Then
DMODE.DMDuplex = PropDuplex
Else
DMODE.DMFields = DMODE.DMFields And Not DM_DUPLEX
End If
DMODE.DMCollate = IIf((PDLG.Flags And CdlPDCollate) <> 0, 1, 0)
PDLG.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, LenB(DMODE))
lpDevMode = GlobalLock(PDLG.hDevMode)
CopyMemory ByVal lpDevMode, DMODE, LenB(DMODE)
GlobalUnlock PDLG.hDevMode
If PropPrinterDefaultInit = False And Not (PropPrinterDriver = vbNullString Or PropPrinterName = vbNullString Or PropPrinterPort = vbNullString) Then
DNAMES.wDriverOffset = 4
DNAMES.wDeviceOffset = DNAMES.wDriverOffset + Len(PropPrinterDriver) + 1
DNAMES.wOutputOffset = DNAMES.wDeviceOffset + Len(PropPrinterName) + 1
DNAMES.wDefault = 0
Buffer = Left$(PropPrinterName & vbNullChar & PropPrinterName & vbNullChar & PropPrinterPort & vbNullChar, CCHDEVNAMESEXTRA)
CopyMemory DNAMES.wExtra(0), ByVal StrPtr(Buffer), LenB(Buffer)
PDLG.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, LenB(DNAMES))
lpDevNames = GlobalLock(PDLG.hDevNames)
CopyMemory ByVal lpDevNames, DNAMES, LenB(DNAMES)
GlobalUnlock PDLG.hDevNames
End If
End If
Dim RetVal As Long
If (PropFlags And CdlPDHelpButton) = CdlPDHelpButton Then
If CommonDialogHelpMsg = 0 Then CommonDialogHelpMsg = RegisterWindowMessage(StrPtr(HELPMSGSTRING))
Call ComCtlsSetSubclass(PDLG.hWndOwner, Me, 5, HELPMSGSTRING & "_5")
RetVal = PrintDialog(PDLG)
Call ComCtlsRemoveSubclass(PDLG.hWndOwner, HELPMSGSTRING & "_5")
Else
RetVal = PrintDialog(PDLG)
End If
If RetVal <> 0 Then
lpDevMode = GlobalLock(PDLG.hDevMode)
CopyMemory DMODE, ByVal lpDevMode, LenB(DMODE)
GlobalUnlock PDLG.hDevMode
GlobalFree PDLG.hDevMode
lpDevNames = GlobalLock(PDLG.hDevNames)
CopyMemory DNAMES, ByVal lpDevNames, LenB(DNAMES)
GlobalUnlock PDLG.hDevNames
GlobalFree PDLG.hDevNames
If (DNAMES.wDefault And DN_DEFAULTPRN) = 0 Then
Buffer = Mid$(DNAMES.wExtra, DNAMES.wDriverOffset - DNAMES.wDriverOffset + 1)
PropPrinterDriver = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
Buffer = Mid$(DNAMES.wExtra, DNAMES.wDeviceOffset - DNAMES.wDriverOffset + 1)
PropPrinterName = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
Buffer = Mid$(DNAMES.wExtra, DNAMES.wOutputOffset - DNAMES.wDriverOffset + 1)
PropPrinterPort = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
If PropPrinterDefault = True Then
Call SetPrinterDefault(PropPrinterName)
PropPrinterDriver = vbNullString
PropPrinterName = vbNullString
PropPrinterPort = vbNullString
End If
Else
PropPrinterDriver = vbNullString
PropPrinterName = vbNullString
PropPrinterPort = vbNullString
End If
If (PDLG.Flags And (PD_ENABLEPRINTHOOK Or PD_ENABLESETUPHOOK)) = 0 Then
PropFlags = PDLG.Flags
Else
PropFlags = PDLG.Flags And Not (PD_ENABLEPRINTHOOK Or PD_ENABLESETUPHOOK)
End If
If (DMODE.DMFields And DM_COLLATE) <> 0 Then
If (PropFlags And CdlPDUseDevModeCopiesAndCollate) <> 0 Then
If DMODE.DMCollate = 1 And (PropFlags And CdlPDCollate) = 0 Then PropFlags = PropFlags Or CdlPDCollate
End If
End If
If (DMODE.DMFields And DM_ORIENTATION) <> 0 Then
PropOrientation = DMODE.DMOrientation
If (CommonDialogDMFieldsExclusion And DM_ORIENTATION) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_ORIENTATION
End If
If (DMODE.DMFields And DM_PAPERSIZE) <> 0 Then
PropPaperSize = DMODE.DMPaperSize
If (CommonDialogDMFieldsExclusion And DM_PAPERSIZE) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_PAPERSIZE
End If
If (DMODE.DMFields And DM_COPIES) <> 0 Then PropCopies = DMODE.DMCopies
If (DMODE.DMFields And DM_DEFAULTSOURCE) <> 0 Then
PropPaperBin = DMODE.DMDefaultSource
If (CommonDialogDMFieldsExclusion And DM_DEFAULTSOURCE) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_DEFAULTSOURCE
End If
If (DMODE.DMFields And DM_PRINTQUALITY) <> 0 Then
PropPrintQuality = DMODE.DMPrintQuality
If (CommonDialogDMFieldsExclusion And DM_PRINTQUALITY) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_PRINTQUALITY
End If
If (DMODE.DMFields And DM_COLOR) <> 0 Then
PropColorMode = DMODE.DMColor
If (CommonDialogDMFieldsExclusion And DM_COLOR) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_COLOR
End If
If (DMODE.DMFields And DM_DUPLEX) <> 0 Then
PropDuplex = DMODE.DMDuplex
If (CommonDialogDMFieldsExclusion And DM_DUPLEX) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_DUPLEX
End If
PropFromPage = CIntToUInt(PDLG.nFromPage)
PropToPage = CIntToUInt(PDLG.nToPage)
PropMin = CIntToUInt(PDLG.nMinPage)
PropMax = CIntToUInt(PDLG.nMaxPage)
If (PropFlags And (CdlPDReturnDC Or CdlPDReturnIC)) <> 0 Then
If PropDC <> 0 Then DeleteObject PropDC
PropDC = PDLG.hDC
End If
ShowPrinter = True
Else
If PDLG.hDevMode <> 0 Then GlobalFree PDLG.hDevMode
If PDLG.hDevNames <> 0 Then GlobalFree PDLG.hDevNames
Dim ErrVal As Long
ErrVal = CommDlgExtendedError()
Select Case ErrVal
Case PDERR_PRINTERNOTFOUND
ERR.Raise Number:=CdlPrinterNotFound, Description:="The [devices] section of WIN.INI does not contain an entry for the printer."
Case PDERR_CREATEICFAILURE
ERR.Raise Number:=CdlCreateICFailure, Description:="The PrintDlg function failed when creating an information context."
Case PDERR_DNDMMISMATCH
ERR.Raise Number:=CdlDndmMismatch, Description:="DevMode and DevNames data structures describe two different printers."
Case PDERR_NODEFAULTPRN
ERR.Raise Number:=CdlNoDefaultPrn, Description:="A default printer does not exist."
Case PDERR_NODEVICES
ERR.Raise Number:=CdlNoDevices, Description:="No printer device-drivers were found."
Case PDERR_INITFAILURE
ERR.Raise Number:=CdlInitFailure, Description:="The PrintDlg function failed during initialization."
Case PDERR_GETDEVMODEFAIL
ERR.Raise Number:=CdlGetDevModeFail, Description:="The printer-device driver failed to initialize a DevMode data structure."
Case PDERR_LOADDRVFAILURE
ERR.Raise Number:=CdlLoadDrvFailure, Description:="The PrintDlg function failed to load the specified printer's device driver."
Case PDERR_RETDEFFAILURE
ERR.Raise Number:=CdlRetDefFailure, Description:="The PDReturnDefault flag was set, but a field was nonzero."
Case PDERR_PARSEFAILURE
ERR.Raise Number:=CdlParseFailure, Description:="The PrintDlg function failed to parse the strings in WIN.INI."
Case 0
If PropCancelError = True Then ERR.Raise Number:=CdlCancel, Description:="Cancel was selected."
Case Else
ERR.Raise Number:=ErrVal, Description:="Unexpected error."
End Select
End If
End Function
Public Function ShowPrinterEx() As CdlPDResultConstants
Dim PDLGEX As PRINTDLGEX, PPAGERANGE As PRINTPAGERANGE, DMODE As DEVMODE, DNAMES As DEVNAMES
Dim lpDevMode As Long, lpDevNames As Long, Buffer As String
With PDLGEX
.lStructSize = LenB(PDLGEX)
.hWndOwner = GetOwnerWindow()
.Flags = PropFlags
.nPageRanges = 1
.nMaxPageRanges = 1
PPAGERANGE.nFromPage = PropFromPage
PPAGERANGE.nToPage = PropToPage
.nMinPage = PropMin
.nMaxPage = PropMax
.nCopies = PropCopies
.lpPageRanges = VarPtr(PPAGERANGE)
Const START_PAGE_GENERAL As Long = &HFFFFFFFF
.nStartPage = START_PAGE_GENERAL
End With
If (PDLGEX.Flags And CdlPDReturnDefault) = 0 Then
DMODE.DMSize = LenB(DMODE)
If PropPrinterDefaultInit = False And Not (PropPrinterDriver = vbNullString Or PropPrinterName = vbNullString Or PropPrinterPort = vbNullString) Then
Buffer = Left$(PropPrinterName, CCHDEVICENAME)
CopyMemory DMODE.DMDeviceName(0), ByVal StrPtr(Buffer), LenB(Buffer)
End If
DMODE.DMFields = DM_ORIENTATION Or DM_PAPERSIZE Or DM_COPIES Or DM_DEFAULTSOURCE Or DM_PRINTQUALITY Or DM_COLOR Or DM_DUPLEX Or DM_COLLATE
If (CommonDialogDMFieldsExclusion And DM_ORIENTATION) = 0 Then
DMODE.DMOrientation = PropOrientation
Else
DMODE.DMFields = DMODE.DMFields And Not DM_ORIENTATION
End If
If (CommonDialogDMFieldsExclusion And DM_PAPERSIZE) = 0 Then
DMODE.DMPaperSize = PropPaperSize
Else
DMODE.DMFields = DMODE.DMFields And Not DM_PAPERSIZE
End If
DMODE.DMCopies = PropCopies
If (CommonDialogDMFieldsExclusion And DM_DEFAULTSOURCE) = 0 Then
DMODE.DMDefaultSource = PropPaperBin
Else
DMODE.DMFields = DMODE.DMFields And Not DM_DEFAULTSOURCE
End If
If (CommonDialogDMFieldsExclusion And DM_PRINTQUALITY) = 0 Then
DMODE.DMPrintQuality = PropPrintQuality
Else
DMODE.DMFields = DMODE.DMFields And Not DM_PRINTQUALITY
End If
If (CommonDialogDMFieldsExclusion And DM_COLOR) = 0 Then
DMODE.DMColor = PropColorMode
Else
DMODE.DMFields = DMODE.DMFields And Not DM_COLOR
End If
If (CommonDialogDMFieldsExclusion And DM_DUPLEX) = 0 Then
DMODE.DMDuplex = PropDuplex
Else
DMODE.DMFields = DMODE.DMFields And Not DM_DUPLEX
End If
DMODE.DMCollate = IIf((PDLGEX.Flags And CdlPDCollate) <> 0, 1, 0)
PDLGEX.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, LenB(DMODE))
lpDevMode = GlobalLock(PDLGEX.hDevMode)
CopyMemory ByVal lpDevMode, DMODE, LenB(DMODE)
GlobalUnlock PDLGEX.hDevMode
If PropPrinterDefaultInit = False And Not (PropPrinterDriver = vbNullString Or PropPrinterName = vbNullString Or PropPrinterPort = vbNullString) Then
DNAMES.wDriverOffset = 4
DNAMES.wDeviceOffset = DNAMES.wDriverOffset + Len(PropPrinterDriver) + 1
DNAMES.wOutputOffset = DNAMES.wDeviceOffset + Len(PropPrinterName) + 1
DNAMES.wDefault = 0
Buffer = Left$(PropPrinterDriver & vbNullChar & PropPrinterName & vbNullChar & PropPrinterPort & vbNullChar, CCHDEVNAMESEXTRA)
CopyMemory DNAMES.wExtra(0), ByVal StrPtr(Buffer), LenB(Buffer)
PDLGEX.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, LenB(DNAMES))
lpDevNames = GlobalLock(PDLGEX.hDevNames)
CopyMemory ByVal lpDevNames, DNAMES, LenB(DNAMES)
GlobalUnlock PDLGEX.hDevNames
End If
End If
Dim ErrVal As Long
If PropHookEvents = False Then
ErrVal = PrintDialogEx(PDLGEX)
Else
PDLGEX.lpCallback = ComCtlsCdlPDEXCallbackPtr(Me)
ErrVal = PrintDialogEx(PDLGEX)
End If
If ErrVal = S_OK Then
If PDLGEX.dwResultAction <> CdlPDResultCancel Or (PDLGEX.Flags And CdlPDReturnDefault) <> 0 Then
lpDevMode = GlobalLock(PDLGEX.hDevMode)
CopyMemory DMODE, ByVal lpDevMode, LenB(DMODE)
GlobalUnlock PDLGEX.hDevMode
GlobalFree PDLGEX.hDevMode
lpDevNames = GlobalLock(PDLGEX.hDevNames)
CopyMemory DNAMES, ByVal lpDevNames, LenB(DNAMES)
GlobalUnlock PDLGEX.hDevNames
GlobalFree PDLGEX.hDevNames
If (DNAMES.wDefault And DN_DEFAULTPRN) = 0 Then
Buffer = Mid$(DNAMES.wExtra, DNAMES.wDriverOffset - DNAMES.wDriverOffset + 1)
PropPrinterDriver = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
Buffer = Mid$(DNAMES.wExtra, DNAMES.wDeviceOffset - DNAMES.wDriverOffset + 1)
PropPrinterName = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
Buffer = Mid$(DNAMES.wExtra, DNAMES.wOutputOffset - DNAMES.wDriverOffset + 1)
PropPrinterPort = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
If PropPrinterDefault = True Then
Call SetPrinterDefault(PropPrinterName)
PropPrinterDriver = vbNullString
PropPrinterName = vbNullString
PropPrinterPort = vbNullString
End If
Else
PropPrinterDriver = vbNullString
PropPrinterName = vbNullString
PropPrinterPort = vbNullString
End If
PropFlags = PDLGEX.Flags
If (DMODE.DMFields And DM_COLLATE) <> 0 Then
If (PropFlags And CdlPDUseDevModeCopiesAndCollate) <> 0 Then
If DMODE.DMCollate = 1 And (PropFlags And CdlPDCollate) = 0 Then PropFlags = PropFlags Or CdlPDCollate
End If
End If
If (DMODE.DMFields And DM_ORIENTATION) <> 0 Then
PropOrientation = DMODE.DMOrientation
If (CommonDialogDMFieldsExclusion And DM_ORIENTATION) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_ORIENTATION
End If
If (DMODE.DMFields And DM_PAPERSIZE) <> 0 Then
PropPaperSize = DMODE.DMPaperSize
If (CommonDialogDMFieldsExclusion And DM_PAPERSIZE) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_PAPERSIZE
End If
If (DMODE.DMFields And DM_COPIES) <> 0 Then PropCopies = DMODE.DMCopies
If (DMODE.DMFields And DM_DEFAULTSOURCE) <> 0 Then
PropPaperBin = DMODE.DMDefaultSource
If (CommonDialogDMFieldsExclusion And DM_DEFAULTSOURCE) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_DEFAULTSOURCE
End If
If (DMODE.DMFields And DM_PRINTQUALITY) <> 0 Then
PropPrintQuality = DMODE.DMPrintQuality
If (CommonDialogDMFieldsExclusion And DM_PRINTQUALITY) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_PRINTQUALITY
End If
If (DMODE.DMFields And DM_COLOR) <> 0 Then
PropColorMode = DMODE.DMColor
If (CommonDialogDMFieldsExclusion And DM_COLOR) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_COLOR
End If
If (DMODE.DMFields And DM_DUPLEX) <> 0 Then
PropDuplex = DMODE.DMDuplex
If (CommonDialogDMFieldsExclusion And DM_DUPLEX) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_DUPLEX
End If
PropFromPage = PPAGERANGE.nFromPage
PropToPage = PPAGERANGE.nToPage
PropMin = PDLGEX.nMinPage
PropMax = PDLGEX.nMaxPage
If (PropFlags And (CdlPDReturnDC Or CdlPDReturnIC)) <> 0 Then
If PropDC <> 0 Then DeleteObject PropDC
PropDC = PDLGEX.hDC
End If
ShowPrinterEx = PDLGEX.dwResultAction
Else
If PropCancelError = True Then ERR.Raise Number:=CdlCancel, Description:="Cancel was selected."
End If
Else
If PDLGEX.hDevMode <> 0 Then GlobalFree PDLGEX.hDevMode
If PDLGEX.hDevNames <> 0 Then GlobalFree PDLGEX.hDevNames
Const E_OUTOFMEMORY As Long = &H8007000E, E_INVALIDARG As Long = &H80070057, E_POINTER As Long = &H80004003, E_HANDLE As Long = &H80070006, E_FAIL As Long = &H80004005
Select Case ErrVal
Case E_OUTOFMEMORY, E_INVALIDARG, E_POINTER, E_HANDLE, E_FAIL
ERR.Raise Number:=CdlInitFailure, Description:="The PrintDlgEx function failed during initialization."
Case Else
ERR.Raise Number:=ErrVal, Description:="Unexpected error."
End Select
End If
End Function
Public Sub ShowHelp()
If PropHelpCommand = 0 Then Exit Sub
Dim dwData As Long
Select Case PropHelpCommand
Case CdlHelpKey, CdlHelpCommandHelp, CdlHelpPartialKey
dwData = StrPtr(PropHelpKey)
Case CdlHelpContext, CdlHelpSetIndex, CdlHelpSetContents, CdlHelpContextPopup
dwData = PropHelpContext
Case CdlHelpQuit, CdlHelpIndex, CdlHelpContents, CdlHelpHelpOnHelp, CdlHelpForceFile
dwData = 0
End Select
If WinHelp(0, StrPtr(PropHelpFile), PropHelpCommand, dwData) = 0 Then ERR.Raise Number:=CdlHelp, Description:="Call to windows help failed."
End Sub
Public Function ShowPageSetup() As Boolean
Dim PSDLG As PAGESETUPDLG, DMODE As DEVMODE, DNAMES As DEVNAMES
Dim lpDevMode As Long, lpDevNames As Long
Dim ObjPrinter As VB.Printer, NewPrinterName As String, Buffer As String
With PSDLG
.lStructSize = LenB(PSDLG)
.hWndOwner = GetOwnerWindow()
If PropHookEvents = False Then
.Flags = PropFlags
Else
.Flags = PSD_ENABLEPAGESETUPHOOK Or PropFlags
.lpfnPageSetupHook = ProcPtr(AddressOf ComCtlsCdlPSDCallbackProc)
Dim This As ISubclass
Set This = Me
.lCustData = ObjPtr(This)
End If
.RCMargin.Left = PropPageLeftMargin
.RCMargin.Top = PropPageTopMargin
.RCMargin.Right = PropPageRightMargin
.RCMargin.Bottom = PropPageBottomMargin
.RCMinMargin.Left = PropPageLeftMinMargin
.RCMinMargin.Top = PropPageTopMinMargin
.RCMinMargin.Right = PropPageRightMinMargin
.RCMinMargin.Bottom = PropPageBottomMinMargin
End With
If (PSDLG.Flags And CdlPSDReturnDefault) = 0 Then
DMODE.DMSize = LenB(DMODE)
If PropPrinterDefaultInit = False And Not (PropPrinterDriver = vbNullString Or PropPrinterName = vbNullString Or PropPrinterPort = vbNullString) Then
Buffer = Left$(PropPrinterName, CCHDEVICENAME)
CopyMemory DMODE.DMDeviceName(0), ByVal StrPtr(Buffer), LenB(Buffer)
End If
DMODE.DMFields = DM_ORIENTATION Or DM_PAPERSIZE Or DM_DEFAULTSOURCE
If (CommonDialogDMFieldsExclusion And DM_ORIENTATION) = 0 Then
DMODE.DMOrientation = PropOrientation
Else
DMODE.DMFields = DMODE.DMFields And Not DM_ORIENTATION
End If
If (CommonDialogDMFieldsExclusion And DM_PAPERSIZE) = 0 Then
DMODE.DMPaperSize = PropPaperSize
Else
DMODE.DMFields = DMODE.DMFields And Not DM_PAPERSIZE
End If
If (CommonDialogDMFieldsExclusion And DM_DEFAULTSOURCE) = 0 Then
DMODE.DMDefaultSource = PropPaperBin
Else
DMODE.DMFields = DMODE.DMFields And Not DM_DEFAULTSOURCE
End If
PSDLG.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, LenB(DMODE))
lpDevMode = GlobalLock(PSDLG.hDevMode)
CopyMemory ByVal lpDevMode, DMODE, LenB(DMODE)
GlobalUnlock PSDLG.hDevMode
If PropPrinterDefaultInit = False And Not (PropPrinterDriver = vbNullString Or PropPrinterName = vbNullString Or PropPrinterPort = vbNullString) Then
DNAMES.wDriverOffset = 4
DNAMES.wDeviceOffset = DNAMES.wDriverOffset + Len(PropPrinterDriver) + 1
DNAMES.wOutputOffset = DNAMES.wDeviceOffset + Len(PropPrinterName) + 1
DNAMES.wDefault = 0
Buffer = Left$(PropPrinterDriver & vbNullChar & PropPrinterName & vbNullChar & PropPrinterPort & vbNullChar, CCHDEVNAMESEXTRA)
CopyMemory DNAMES.wExtra(0), ByVal StrPtr(Buffer), LenB(Buffer)
PSDLG.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, LenB(DNAMES))
lpDevNames = GlobalLock(PSDLG.hDevNames)
CopyMemory ByVal lpDevNames, DNAMES, LenB(DNAMES)
GlobalUnlock PSDLG.hDevNames
End If
End If
Dim RetVal As Long
If (PropFlags And CdlPSDHelpButton) = CdlPSDHelpButton Then
If CommonDialogHelpMsg = 0 Then CommonDialogHelpMsg = RegisterWindowMessage(StrPtr(HELPMSGSTRING))
Call ComCtlsSetSubclass(PSDLG.hWndOwner, Me, 7, HELPMSGSTRING & "_7")
RetVal = PageSetupDialog(PSDLG)
Call ComCtlsRemoveSubclass(PSDLG.hWndOwner, HELPMSGSTRING & "_7")
Else
RetVal = PageSetupDialog(PSDLG)
End If
If RetVal <> 0 Then
lpDevMode = GlobalLock(PSDLG.hDevMode)
CopyMemory DMODE, ByVal lpDevMode, LenB(DMODE)
GlobalUnlock PSDLG.hDevMode
GlobalFree PSDLG.hDevMode
lpDevNames = GlobalLock(PSDLG.hDevNames)
CopyMemory DNAMES, ByVal lpDevNames, LenB(DNAMES)
GlobalUnlock PSDLG.hDevNames
GlobalFree PSDLG.hDevNames
If (PSDLG.Flags And PSD_ENABLEPAGESETUPHOOK) = 0 Then
PropFlags = PSDLG.Flags
Else
PropFlags = PSDLG.Flags And Not PSD_ENABLEPAGESETUPHOOK
End If
If (DMODE.DMFields And DM_ORIENTATION) <> 0 Then
PropOrientation = DMODE.DMOrientation
If (CommonDialogDMFieldsExclusion And DM_ORIENTATION) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_ORIENTATION
End If
If (DMODE.DMFields And DM_PAPERSIZE) <> 0 Then
PropPaperSize = DMODE.DMPaperSize
If (CommonDialogDMFieldsExclusion And DM_PAPERSIZE) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_PAPERSIZE
End If
If (DMODE.DMFields And DM_DEFAULTSOURCE) <> 0 Then
PropPaperBin = DMODE.DMDefaultSource
If (CommonDialogDMFieldsExclusion And DM_DEFAULTSOURCE) <> 0 Then CommonDialogDMFieldsExclusion = CommonDialogDMFieldsExclusion And Not DM_DEFAULTSOURCE
End If
PropPageLeftMargin = PSDLG.RCMargin.Left
PropPageTopMargin = PSDLG.RCMargin.Top
PropPageRightMargin = PSDLG.RCMargin.Right
PropPageBottomMargin = PSDLG.RCMargin.Bottom
ShowPageSetup = True
Else
If PSDLG.hDevMode <> 0 Then GlobalFree PSDLG.hDevMode
If PSDLG.hDevNames <> 0 Then GlobalFree PSDLG.hDevNames
Dim ErrVal As Long
ErrVal = CommDlgExtendedError()
Select Case ErrVal
Case PDERR_PRINTERNOTFOUND
ERR.Raise Number:=CdlPrinterNotFound, Description:="The [devices] section of WIN.INI does not contain an entry for the printer."
Case PDERR_CREATEICFAILURE
ERR.Raise Number:=CdlCreateICFailure, Description:="The PageSetupDlg function failed when creating an information context."
Case PDERR_DNDMMISMATCH
ERR.Raise Number:=CdlDndmMismatch, Description:="DevMode and DevNames data structures describe two different printers."
Case PDERR_NODEFAULTPRN
ERR.Raise Number:=CdlNoDefaultPrn, Description:="A default printer does not exist."
Case PDERR_NODEVICES
ERR.Raise Number:=CdlNoDevices, Description:="No printer device-drivers were found."
Case PDERR_INITFAILURE
ERR.Raise Number:=CdlInitFailure, Description:="The PageSetupDlg function failed during initialization."
Case PDERR_GETDEVMODEFAIL
ERR.Raise Number:=CdlGetDevModeFail, Description:="The printer-device driver failed to initialize a DevMode data structure."
Case PDERR_LOADDRVFAILURE
ERR.Raise Number:=CdlLoadDrvFailure, Description:="The PageSetupDlg function failed to load the specified printer's device driver."
Case PDERR_RETDEFFAILURE
ERR.Raise Number:=CdlRetDefFailure, Description:="The PDReturnDefault flag was set, but a field was nonzero."
Case PDERR_PARSEFAILURE
ERR.Raise Number:=CdlParseFailure, Description:="The PageSetupDlg function failed to parse the strings in WIN.INI."
Case 0
If PropCancelError = True Then ERR.Raise Number:=CdlCancel, Description:="Cancel was selected."
Case Else
ERR.Raise Number:=ErrVal, Description:="Unexpected error."
End Select
End If
End Function
Private Sub SetPrinterDefault(ByVal NewPrinterName As String)
Dim Length As Long
GetDefaultPrinter 0, Length
If Length > 0 Then
Dim Buffer As String
Buffer = String(Length, vbNullChar)
GetDefaultPrinter StrPtr(Buffer), Length
If StrComp(Left$(Buffer, InStr(Buffer, vbNullChar) - 1), NewPrinterName, vbTextCompare) <> 0 Then SetDefaultPrinter StrPtr(NewPrinterName)
End If
End Sub
Public Function ShowFolderBrowser() As Boolean
Dim BIF As BROWSEINFO, IDList As Long
With BIF
.hWndOwner = GetOwnerWindow()
Select Case VarType(PropRootFolder)
Case vbEmpty
.pIDLRoot = 0
Case vbLong, vbInteger, vbByte
SHGetFolderLocation 0, PropRootFolder, 0, 0, .pIDLRoot
Case vbString
If ComCtlsW2KCompatibility() = False Then
.pIDLRoot = ILCreateFromPath(StrPtr(Left$(PropRootFolder, MAX_PATH)))
Else
.pIDLRoot = ILCreateFromPath_W2K(StrPtr(Left$(PropRootFolder, MAX_PATH)))
End If
Case vbDouble, vbSingle
SHGetFolderLocation 0, CLng(PropRootFolder), 0, 0, .pIDLRoot
End Select
.lpszTitle = StrPtr(PropDialogTitle)
.ulFlags = PropFlags
.lpfnCallback = ProcPtr(AddressOf ComCtlsCdlBIFCallbackProc)
Dim This As ISubclass
Set This = Me
.lParam = ObjPtr(This)
IDList = SHBrowseForFolder(BIF)
If .pIDLRoot <> 0 Then CoTaskMemFree .pIDLRoot
End With
If IDList <> 0 Then
Dim Buffer As String, PathName As String
Buffer = String(MAX_PATH, vbNullChar)
If SHGetPathFromIDList(IDList, StrPtr(Buffer)) <> 0 Then PathName = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
CoTaskMemFree IDList
On Error Resume Next
Dim Attributes As VbFileAttribute
Attributes = GetAttr(PathName)
On Error GoTo 0
If (Attributes And (vbDirectory Or vbVolume)) <> 0 Then
If Not PathName = vbNullString Then PathName = PathName & IIf(Right$(PathName, 1) = "", "", "")
PropFileOffset = 0
PropFileTitle = vbNullString
Else
PropFileOffset = InStrRev(PathName, "")
PropFileTitle = Mid$(PathName, PropFileOffset + 1)
End If
PropFileName = PathName
ShowFolderBrowser = True
Else
If PropCancelError = True Then ERR.Raise Number:=CdlCancel, Description:="Cancel was selected."
End If
End Function
Public Function ShowFind() As Long
If CommonDialogFRDialogHandle <> 0 Then Exit Function
Dim FR As FINDREPLACE
LSet CommonDialogFR = FR
With CommonDialogFR
.lStructSize = LenB(CommonDialogFR)
.hWndOwner = GetOwnerWindow()
If PropHookEvents = False Then
.Flags = PropFlags
Else
.Flags = FR_ENABLEHOOK Or PropFlags
.lpfnHook = ProcPtr(AddressOf ComCtlsCdlFR1CallbackProc)
Dim This As ISubclass
Set This = Me
.lCustData = ObjPtr(This)
End If
CommonDialogFRBufferFindWhat = PropFindWhat
If StrPtr(CommonDialogFRBufferFindWhat) = 0 Then CommonDialogFRBufferFindWhat = ""
.lpstrFindWhat = StrPtr(CommonDialogFRBufferFindWhat)
.wFindWhatLen = 256
End With
If (PropFlags And CdlFRHelpButton) = CdlFRHelpButton Then
If CommonDialogHelpMsg = 0 Then CommonDialogHelpMsg = RegisterWindowMessage(StrPtr(HELPMSGSTRING))
End If
If CommonDialogFindMsg = 0 Then CommonDialogFindMsg = RegisterWindowMessage(StrPtr(FINDMSGSTRING))
CommonDialogFRDialogHandle = FindText(CommonDialogFR)
If CommonDialogFRDialogHandle <> 0 Then
With CommonDialogFR
.lCustData = CommonDialogFRDialogHandle
Call ComCtlsSetSubclass(.hWndOwner, Me, 9, FINDMSGSTRING & "_9_" & CStr(.lCustData))
Call ComCtlsCdlFRAddHook(.lCustData)
ShowFind = .lCustData
End With
Else
Dim ErrVal As Long
ErrVal = CommDlgExtendedError()
Select Case ErrVal
Case FRERR_BUFFERLENGTHZERO
ERR.Raise Number:=CdlBufferLengthZero, Description:="The buffer at which the member LpstrFindWhat points is invalid."
Case Else
ERR.Raise Number:=ErrVal, Description:="Unexpected error."
End Select
End If
End Function
Public Function ShowReplace() As Long
If CommonDialogFRDialogHandle <> 0 Then Exit Function
Dim FR As FINDREPLACE
LSet CommonDialogFR = FR
With CommonDialogFR
.lStructSize = LenB(CommonDialogFR)
.hWndOwner = GetOwnerWindow()
If PropHookEvents = False Then
.Flags = PropFlags
Else
.Flags = FR_ENABLEHOOK Or PropFlags
.lpfnHook = ProcPtr(AddressOf ComCtlsCdlFR2CallbackProc)
Dim This As ISubclass
Set This = Me
.lCustData = ObjPtr(This)
End If
CommonDialogFRBufferFindWhat = PropFindWhat
If StrPtr(CommonDialogFRBufferFindWhat) = 0 Then CommonDialogFRBufferFindWhat = ""
.lpstrFindWhat = StrPtr(CommonDialogFRBufferFindWhat)
CommonDialogFRBufferReplaceWith = PropReplaceWith
If StrPtr(CommonDialogFRBufferReplaceWith) = 0 Then CommonDialogFRBufferReplaceWith = ""
.lpstrReplaceWith = StrPtr(CommonDialogFRBufferReplaceWith)
.wFindWhatLen = 256
.wReplaceWithLen = 256
End With
If (PropFlags And CdlFRHelpButton) = CdlFRHelpButton Then
If CommonDialogHelpMsg = 0 Then CommonDialogHelpMsg = RegisterWindowMessage(StrPtr(HELPMSGSTRING))
End If
If CommonDialogFindMsg = 0 Then CommonDialogFindMsg = RegisterWindowMessage(StrPtr(FINDMSGSTRING))
CommonDialogFRDialogHandle = ReplaceText(CommonDialogFR)
If CommonDialogFRDialogHandle <> 0 Then
With CommonDialogFR
.lCustData = CommonDialogFRDialogHandle
Call ComCtlsSetSubclass(.hWndOwner, Me, 10, FINDMSGSTRING & "_10_" & CStr(.lCustData))
Call ComCtlsCdlFRAddHook(.lCustData)
ShowReplace = .lCustData
End With
Else
Dim ErrVal As Long
ErrVal = CommDlgExtendedError()
Select Case ErrVal
Case FRERR_BUFFERLENGTHZERO
ERR.Raise Number:=CdlBufferLengthZero, Description:="The buffer at which the member LpstrFindWhat and/or LpstrReplaceWith points is invalid."
Case Else
ERR.Raise Number:=ErrVal, Description:="Unexpected error."
End Select
End If
End Function
Private Function GetOwnerWindow() As Long
Dim hwnd As Long, hWndMDIClient As Long
hwnd = GetActiveWindow()
If hwnd <> 0 Then hWndMDIClient = FindWindowEx(hwnd, 0, StrPtr("MDIClient"), 0)
If hWndMDIClient <> 0 Then
Const WM_MDIGETACTIVE As Long = &H229
GetOwnerWindow = SendMessage(hWndMDIClient, WM_MDIGETACTIVE, 0, ByVal 0&)
Else
GetOwnerWindow = hwnd
End If
End Function
Private Function ISubclass_Message(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal dwRefData As Long) As Long
If dwRefData > 0 Then
ISubclass_Message = WindowProcOwner(hwnd, wMsg, wParam, lParam, dwRefData)
Else
ISubclass_Message = CallbackProcDialog(hwnd, wMsg, wParam, lParam, dwRefData)
End If
End Function
Private Function WindowProcOwner(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal dwRefData As Long) As Long
Dim hWndFocus As Long
If wMsg = CommonDialogHelpMsg And CommonDialogHelpMsg <> 0 Then
Dim Handled As Boolean
hWndFocus = GetFocus()
RaiseEvent Help(Handled, CUIntToInt(dwRefData And &HFFFF&), wParam)
If GetFocus() <> hWndFocus And hWndFocus <> 0 Then SetFocusAPI hWndFocus
If Handled = False Then Me.ShowHelp
End If
If wMsg = CommonDialogFindMsg And CommonDialogFindMsg <> 0 Then
Dim FR As FINDREPLACE
CopyMemory ByVal VarPtr(FR), ByVal lParam, LenB(FR)
If (FR.lCustData = CommonDialogFRDialogHandle Or FR.lCustData = 0) And CommonDialogFRDialogHandle <> 0 Then
If (FR.Flags And FR_DIALOGTERM) = FR_DIALOGTERM Then
WindowProcOwner = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
Call ComCtlsRemoveSubclass(hwnd, FINDMSGSTRING & "_" & CStr(dwRefData) & "_" & CStr(CommonDialogFRDialogHandle))
Call ComCtlsCdlFRReleaseHook(CommonDialogFRDialogHandle)
CommonDialogFRDialogHandle = 0
Exit Function
Else
If (FR.Flags And FR_ENABLEHOOK) = 0 Then
PropFlags = FR.Flags
Else
PropFlags = FR.Flags And Not FR_ENABLEHOOK
End If
Dim Length As Long
If FR.lpstrFindWhat <> 0 Then
Length = lstrlen(FR.lpstrFindWhat)
PropFindWhat = String(Length, vbNullChar)
CopyMemory ByVal StrPtr(PropFindWhat), ByVal FR.lpstrFindWhat, Length * 2
End If
If FR.lpstrReplaceWith <> 0 Then
Length = lstrlen(FR.lpstrReplaceWith)
PropReplaceWith = String(Length, vbNullChar)
CopyMemory ByVal StrPtr(PropReplaceWith), ByVal FR.lpstrReplaceWith, Length * 2
End If
hWndFocus = GetFocus()
Select Case True
Case CBool((FR.Flags And CdlFRFindNext) = CdlFRFindNext)
RaiseEvent FindNext
Case CBool((FR.Flags And CdlFRReplace) = CdlFRReplace)
RaiseEvent Replace
Case CBool((FR.Flags And CdlFRReplaceAll) = CdlFRFindNext)
RaiseEvent ReplaceAll
End Select
If GetFocus() <> hWndFocus And hWndFocus <> 0 Then SetFocusAPI hWndFocus
End If
End If
End If
WindowProcOwner = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
End Function
Private Function CallbackProcDialog(ByVal hDlg As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal dwRefData As Long) As Long
Dim hWndFocus As Long, Cancel As Boolean, Buffer As String, Length As Long
CallbackProcDialog = 0
Select Case dwRefData
Case -1, -2, -1001, -1002
Dim OFN As OPENFILENAME, FileName As String, Result As CdlOFNShareViResultConstants
If dwRefData > -1000 Then
If wMsg = WM_NOTIFY Then
Dim NM As NMHDR, NMOFN As NMOFNOTIFY
CopyMemory NM, ByVal lParam, LenB(NM)
Const H_MAX As Long = (&HFFFF + 1)
Const CDN_FIRST As Long = (H_MAX - 601)
Const CDN_INITDONE As Long = (CDN_FIRST - 0)
Const CDN_SHAREVIOLATION As Long = (CDN_FIRST - 3)
Const CDN_FILEOK As Long = (CDN_FIRST - 5)
Select Case NM.Code
Case CDN_INITDONE
RaiseEvent InitDialog(CUIntToInt(-dwRefData And &HFFFF&), hDlg)
Case CDN_SHAREVIOLATION
CopyMemory NMOFN, ByVal lParam, LenB(NMOFN)
Buffer = String(PropMaxFileSize, vbNullChar)
With NMOFN
If .lpszFileShareVi <> 0 Then
Length = lstrlen(.lpszFileShareVi)
If Length > PropMaxFileSize Then Length = PropMaxFileSize
CopyMemory ByVal StrPtr(Buffer), ByVal .lpszFileShareVi, Length * 2
End If
End With
hWndFocus = GetFocus()
FileName = Left$(Buffer, InStr(Buffer & vbNullChar, vbNullChar) - 1)
RaiseEvent FileShareViolation(FileName, Result, hDlg)
If GetFocus() <> hWndFocus And hWndFocus <> 0 Then SetFocusAPI hWndFocus
CallbackProcDialog = Result
SetWindowLong hDlg, DWL_MSGRESULT, Result
Case CDN_FILEOK
CopyMemory NMOFN, ByVal lParam, LenB(NMOFN)
If NMOFN.lpOFN <> 0 Then CopyMemory OFN, ByVal NMOFN.lpOFN, ByVal LenB(OFN)
With OFN
Buffer = String(PropMaxFileSize, vbNullChar)
If .lpstrFile <> 0 Then
Length = lstrlen(.lpstrFile)
If Length > PropMaxFileSize Then Length = PropMaxFileSize
CopyMemory ByVal StrPtr(Buffer), ByVal .lpstrFile, Length * 2
End If
hWndFocus = GetFocus()
If .nFileOffset > 0 Then
If Mid$(Buffer, .nFileOffset, 1) = vbNullChar Then
FileName = Left$(Buffer, InStr(Buffer & vbNullChar & vbNullChar, vbNullChar & vbNullChar) - 1)
RaiseEvent FileValidate(FileName, vbNullString, .nFileOffset, Cancel, hDlg)
Else
FileName = Left$(Buffer, InStr(Buffer & vbNullChar, vbNullChar) - 1)
RaiseEvent FileValidate(FileName, Mid$(FileName, .nFileOffset + 1), .nFileOffset, Cancel, hDlg)
End If
End If
If GetFocus() <> hWndFocus And hWndFocus <> 0 Then SetFocusAPI hWndFocus
End With
If Cancel = True Then
CallbackProcDialog = 1
SetWindowLong hDlg, DWL_MSGRESULT, 1
End If
End Select
End If
Else
If wMsg = WM_INITDIALOG Then
If CommonDialogShareViMsg = 0 Then CommonDialogShareViMsg = RegisterWindowMessage(StrPtr(SHAREVISTRING))
If CommonDialogFileOKMsg = 0 Then CommonDialogFileOKMsg = RegisterWindowMessage(StrPtr(FILEOKSTRING))
RaiseEvent InitDialog(CUIntToInt(-(dwRefData + 1000) And &HFFFF&), hDlg)
ElseIf wMsg = CommonDialogShareViMsg And CommonDialogShareViMsg <> 0 Then
Buffer = String(PropMaxFileSize, vbNullChar)
If lParam <> 0 Then
Length = lstrlen(lParam)
If Length > PropMaxFileSize Then Length = PropMaxFileSize
CopyMemory ByVal StrPtr(Buffer), ByVal lParam, Length * 2
End If
hWndFocus = GetFocus()
FileName = Left$(Buffer, InStr(Buffer & vbNullChar, vbNullChar) - 1)
RaiseEvent FileShareViolation(FileName, Result, hDlg)
If GetFocus() <> hWndFocus And hWndFocus <> 0 Then SetFocusAPI hWndFocus
CallbackProcDialog = Result
ElseIf wMsg = CommonDialogFileOKMsg And CommonDialogFileOKMsg <> 0 Then
CopyMemory OFN, ByVal lParam, LenB(OFN)
With OFN
Buffer = String(PropMaxFileSize, vbNullChar)
If .lpstrFile <> 0 Then
Length = lstrlen(.lpstrFile)
If Length > PropMaxFileSize Then Length = PropMaxFileSize
CopyMemory ByVal StrPtr(Buffer), ByVal .lpstrFile, Length * 2
End If
hWndFocus = GetFocus()
If .nFileOffset > 0 Then
If Mid$(Buffer, .nFileOffset, 1) = vbNullChar Then
FileName = Left$(Buffer, InStr(Buffer & vbNullChar & vbNullChar, vbNullChar & vbNullChar) - 1)
RaiseEvent FileValidate(FileName, vbNullString, .nFileOffset, Cancel, hDlg)
Else
FileName = Left$(Buffer, InStr(Buffer & vbNullChar, vbNullChar) - 1)
RaiseEvent FileValidate(FileName, Mid$(FileName, .nFileOffset + 1), .nFileOffset, Cancel, hDlg)
End If
End If
If GetFocus() <> hWndFocus And hWndFocus <> 0 Then SetFocusAPI hWndFocus
End With
If Cancel = True Then CallbackProcDialog = 1
End If
End If
Case -3
If wMsg = WM_INITDIALOG Then
If CommonDialogColorOKMsg = 0 Then CommonDialogColorOKMsg = RegisterWindowMessage(StrPtr(COLOROKSTRING))
RaiseEvent InitDialog(CUIntToInt(-dwRefData And &HFFFF&), hDlg)
ElseIf wMsg = CommonDialogColorOKMsg And CommonDialogColorOKMsg <> 0 Then
Dim CHCLR As TCHOOSECOLOR, OldColor As Long
CopyMemory CHCLR, ByVal lParam, LenB(CHCLR)
With CHCLR
OldColor = .RGBResult
hWndFocus = GetFocus()
RaiseEvent ColorValidate(.RGBResult, Cancel, hDlg)
If GetFocus() <> hWndFocus And hWndFocus <> 0 Then SetFocusAPI hWndFocus
If Cancel = True Then
CallbackProcDialog = 1
If OldColor <> .RGBResult Then ' The SetRGB message works only properly when the callback procedure returns a nonzero value
If CommonDialogSetRGBMsg = 0 Then CommonDialogSetRGBMsg = RegisterWindowMessage(StrPtr(SETRGBSTRING))
SendMessage hDlg, CommonDialogSetRGBMsg, 0, ByVal .RGBResult
End If
End If
End With
End If
Case -4
If wMsg = WM_INITDIALOG Then
RaiseEvent InitDialog(CUIntToInt(-dwRefData And &HFFFF&), hDlg)
ElseIf wMsg = WM_COMMAND Then
If HiWord(wParam) = BN_CLICKED Then
Const IDC_APPLY_BUTTON As Long = 1026
If LoWord(wParam) = IDC_APPLY_BUTTON Then
Const IDC_FACE_COMBOBOX As Long = 1136, IDC_STYLE_COMBOBOX As Long = 1137, IDC_SIZE_COMBOBOX As Long = 1138, IDC_COLOR_COMBOBOX As Long = 1139, IDC_SCRIPT_COMBOBOX As Long = 1140
Const CB_ERR As Long = (-1)
Const CB_GETCURSEL As Long = &H147
Const CB_GETITEMDATA As Long = &H150
Dim Flags As Long, iItem As Long
Flags = PropFlags
' The CdlCFNo***Sel flags needs to be adjusted, if necessary.
iItem = SendDlgItemMessage(hDlg, IDC_FACE_COMBOBOX, CB_GETCURSEL, 0, ByVal 0&)
If (Flags And CdlCFNoFaceSel) = 0 Then
If iItem = CB_ERR Then Flags = Flags Or CdlCFNoFaceSel
ElseIf (Flags And CdlCFNoFaceSel) = CdlCFNoFaceSel Then
If Not iItem = CB_ERR Then Flags = Flags And Not CdlCFNoFaceSel
End If
iItem = SendDlgItemMessage(hDlg, IDC_STYLE_COMBOBOX, CB_GETCURSEL, 0, ByVal 0&)
If (Flags And CdlCFNoStyleSel) = 0 Then
If iItem = CB_ERR Then Flags = Flags Or CdlCFNoStyleSel
ElseIf (Flags And CdlCFNoStyleSel) = CdlCFNoStyleSel Then
If Not iItem = CB_ERR Then Flags = Flags And Not CdlCFNoStyleSel
End If
iItem = SendDlgItemMessage(hDlg, IDC_SIZE_COMBOBOX, CB_GETCURSEL, 0, ByVal 0&)
If (Flags And CdlCFNoSizeSel) = 0 Then
If iItem = CB_ERR Then Flags = Flags Or CdlCFNoSizeSel
ElseIf (Flags And CdlCFNoSizeSel) = CdlCFNoSizeSel Then
If Not iItem = CB_ERR Then Flags = Flags And Not CdlCFNoSizeSel
End If
iItem = SendDlgItemMessage(hDlg, IDC_SCRIPT_COMBOBOX, CB_GETCURSEL, 0, ByVal 0&)
If (Flags And CdlCFNoScriptSel) = 0 Then
If iItem = CB_ERR Then Flags = Flags Or CdlCFNoScriptSel
ElseIf (Flags And CdlCFNoScriptSel) = CdlCFNoScriptSel Then
If Not iItem = CB_ERR Then Flags = Flags And Not CdlCFNoScriptSel
End If
Const WM_CHOOSEFONT_GETLOGFONT As Long = (WM_USER + 1)
Dim LF As LOGFONT, RGBColor As Long
SendMessage hDlg, WM_CHOOSEFONT_GETLOGFONT, 0, ByVal VarPtr(LF)
iItem = SendDlgItemMessage(hDlg, IDC_COLOR_COMBOBOX, CB_GETCURSEL, 0, ByVal 0&)
If Not iItem = CB_ERR Then RGBColor = SendDlgItemMessage(hDlg, IDC_COLOR_COMBOBOX, CB_GETITEMDATA, iItem, ByVal 0&)
With LF
RaiseEvent FontApply(Flags, Left$(.LFFaceName(), InStr(.LFFaceName(), vbNullChar) - 1), CSng(MulDiv(-.LFHeight, 72, DPI_Y())), CBool(.LFWeight = FW_BOLD), CBool(.LFItalic <> 0), CBool(.LFStrikeOut <> 0), CBool(.LFUnderline <> 0), CInt(.LFCharset), RGBColor, hDlg)
End With
End If
End If
End If
Case -5, -7
If wMsg = WM_INITDIALOG Then RaiseEvent InitDialog(CUIntToInt(-dwRefData And &HFFFF&), hDlg)
Case -8
Dim Text As String
Const BFFM_INITIALIZED As Long = 1, BFFM_SELCHANGED As Long = 2, BFFM_VALIDATEFAILED As Long = 4
Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
Const BFFM_SETSTATUSTEXT As Long = BFFM_SETSTATUSTEXTW
Const BFFM_ENABLEOK As Long = (WM_USER + 101)
Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Const BFFM_SETSELECTION As Long = BFFM_SETSELECTIONW
Select Case wMsg
Case BFFM_INITIALIZED
If Not PropInitDir = vbNullString Then SendMessage hDlg, BFFM_SETSELECTION, 1, ByVal StrPtr(PropInitDir)
RaiseEvent InitDialog(CUIntToInt(-dwRefData And &HFFFF&), hDlg)
Case BFFM_SELCHANGED
Dim RetVal As Long
If lParam <> 0 Then
Buffer = String(MAX_PATH, vbNullChar)
RetVal = SHGetPathFromIDList(lParam, StrPtr(Buffer))
If RetVal <> 0 Then
Text = Left$(Buffer, InStr(Buffer, vbNullChar) - 1)
On Error Resume Next
Dim Attributes As VbFileAttribute
Attributes = GetAttr(Text)
On Error GoTo 0
If (Attributes And (vbDirectory Or vbVolume)) <> 0 Then If Not Text = vbNullString Then Text = Text & IIf(Right$(Text, 1) = "", "", "")
End If
End If
If (PropFlags And CdlBIFStatusText) = CdlBIFStatusText Then SendMessage hDlg, BFFM_SETSTATUSTEXT, 0, ByVal StrPtr(Text)
If (PropFlags And CdlBIFReturnOnlyFSDirs) = CdlBIFReturnOnlyFSDirs Then
' If the CdlBIFReturnOnlyFSDirs flag is set, the OK button remains enabled if the user selects a "\\ServerName" item.
' "\\ServerName" is not a file system path, but a machine name. Whereas "\\ServerName\ShareName" is a file system path.
' Therefore it is necessary to check the return value of SHGetPathFromIDList and enable/disable the OK button accordingly.
SendMessage hDlg, BFFM_ENABLEOK, 0, ByVal RetVal
End If
Case BFFM_VALIDATEFAILED
If lParam <> 0 Then
Length = lstrlen(lParam)
Text = String(Length, vbNullChar)
CopyMemory ByVal StrPtr(Text), ByVal lParam, Length * 2
End If
hWndFocus = GetFocus()
RaiseEvent FolderBrowserValidateFailed(Text, Cancel, hDlg)
If GetFocus() <> hWndFocus And hWndFocus <> 0 Then SetFocusAPI hWndFocus
If Cancel = True Then CallbackProcDialog = 1
End Select
Case -9, -10
If wMsg = WM_INITDIALOG Then RaiseEvent InitDialog(CUIntToInt(-dwRefData And &HFFFF&), hDlg)
End Select
End Function

复制代码

cStringBuilder

'字符串构建类
'原作者：巴西_prince
'原网站链接：https://cloud.tencent.com/developer/article/1496152
'原发布时间：2019-08-28
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private m_sString As String
Private m_iChunkSize As Long
Private m_iPos As Long
Private m_iLen As Long
Public Property Get Length() As Long
Length = m_iPos \ 2
End Property
Public Property Get Capacity() As Long
Capacity = m_iLen \ 2
End Property
Public Property Get ChunkSize() As Long
ChunkSize = m_iChunkSize \ 2
End Property
Public Property Let ChunkSize(ByVal iChunkSize As Long)
m_iChunkSize = iChunkSize * 2
End Property
Public Property Get toString() As String
If m_iPos > 0 Then
toString = Left$(m_sString, m_iPos \ 2)
End If
End Property
Public Property Let TheString(ByRef sThis As String)
Dim lLen As Long
lLen = LenB(sThis)
If lLen = 0 Then
m_sString = ""
m_iPos = 0
m_iLen = 0
Else
If m_iLen < lLen Then
Do
m_sString = m_sString & Space$(m_iChunkSize \ 2)
m_iLen = m_iLen + m_iChunkSize
Loop While m_iLen < lLen
End If
CopyMemory ByVal StrPtr(m_sString), ByVal StrPtr(sThis), lLen
m_iPos = lLen
End If
End Property
Public Sub Clear()
m_sString = ""
m_iPos = 0
m_iLen = 0
End Sub
Public Sub AppendNL(ByRef sThis As String)
Append sThis
Append vbCrLf
End Sub
Public Sub Append(ByRef sThis As String)
Dim lLen As Long
Dim lLenPlusPos As Long
lLen = LenB(sThis)
lLenPlusPos = lLen + m_iPos
If lLenPlusPos > m_iLen Then
Dim lTemp As Long
lTemp = m_iLen
Do While lTemp < lLenPlusPos
lTemp = lTemp + m_iChunkSize
Loop
m_sString = m_sString & Space$((lTemp - m_iLen) \ 2)
m_iLen = lTemp
End If
CopyMemory ByVal UnsignedAdd(StrPtr(m_sString), m_iPos), ByVal StrPtr(sThis), lLen
m_iPos = m_iPos + lLen
End Sub
Public Sub AppendByVal(ByVal sThis As String)
Append sThis
End Sub
Public Sub Insert(ByVal iIndex As Long, ByRef sThis As String)
Dim lLen As Long
Dim lPos As Long
Dim lSize As Long
If (iIndex * 2 > m_iPos) Then
ERR.Raise 9
Else
lLen = LenB(sThis)
If (m_iPos + lLen) > m_iLen Then
m_sString = m_sString & Space$(m_iChunkSize \ 2)
m_iLen = m_iLen + m_iChunkSize
End If
lPos = UnsignedAdd(StrPtr(m_sString), iIndex * 2)
lSize = m_iPos - iIndex * 2
CopyMemory ByVal UnsignedAdd(lPos, lLen), ByVal lPos, lSize
CopyMemory ByVal lPos, ByVal StrPtr(sThis), lLen
m_iPos = m_iPos + lLen
End If
End Sub
Public Sub InsertByVal(ByVal iIndex As Long, ByVal sThis As String)
Insert iIndex, sThis
End Sub
Public Sub Remove(ByVal iIndex As Long, ByVal lLen As Long)
Dim lSrc As Long
Dim lDst As Long
Dim lSize As Long
If (iIndex * 2 > m_iPos) Then
ERR.Raise 9
Else
If ((iIndex + lLen) * 2 > m_iPos) Then
ERR.Raise 9
Else
lSrc = UnsignedAdd(StrPtr(m_sString), (iIndex + lLen) * 2)
lDst = UnsignedAdd(StrPtr(m_sString), iIndex * 2)
lSize = (m_iPos - (iIndex + lLen) * 2)
CopyMemory ByVal lDst, ByVal lSrc, lSize
m_iPos = m_iPos - lLen * 2
End If
End If
End Sub
Public Function Find(ByVal sToFind As String, _
Optional ByVal lStartIndex As Long = 1, _
Optional ByVal compare As VbCompareMethod = vbTextCompare _
) As Long
Dim lInstr As Long
If (lStartIndex > 0) Then
lInstr = InStr(lStartIndex, m_sString, sToFind, compare)
Else
lInstr = InStr(m_sString, sToFind, compare)
End If
If (lInstr < m_iPos \ 2) Then
Find = lInstr
End If
End Function
Public Sub HeapMinimize()
Dim iLen As Long
If (m_iLen - m_iPos) > m_iChunkSize Then
iLen = m_iLen
Do While (iLen - m_iPos) > m_iChunkSize
iLen = iLen - m_iChunkSize
Loop
m_sString = Left$(m_sString, iLen \ 2)
m_iLen = iLen
End If
End Sub
Private Function UnsignedAdd(Start As Long, Incr As Long) As Long
If Start And &H80000000 Then
UnsignedAdd = Start + Incr
ElseIf (Start Or &H80000000) < -Incr Then
UnsignedAdd = Start + Incr
Else
UnsignedAdd = (Start + &H80000000) + (Incr + &H80000000)
End If
End Function
Private Sub Class_Initialize()
m_iChunkSize = 16384
End Sub

复制代码

JSON.cls

'将json的花括号转化为vba的字典，将方括号转化为vba的集合
Option Explicit
Const INVALID_JSON As Long = 1
Const INVALID_OBJECT As Long = 2
Const INVALID_ARRAY As Long = 3
Const INVALID_BOOLEAN As Long = 4
Const INVALID_NULL As Long = 5
Const INVALID_KEY As Long = 6
Const INVALID_RPC_CALL As Long = 7
Private psErrors As String
Public Function GetParserErrors() As String
GetParserErrors = psErrors
End Function
Public Function ClearParserErrors() As String
psErrors = ""
End Function
'
' 解析字符串并创建JSON对象
'
Public Function parse(ByVal str As String) As Object
Dim Index As Long
Index = 1
psErrors = ""
On Error Resume Next
Call skipChar(str, Index)
Select Case Mid(str, Index, 1)
Case "{"
Set parse = parseObject(str, Index)
Case "["
Set parse = parseArray(str, Index)
Case Else
psErrors = "Invalid JSON"
End Select
End Function
'
' 解析键/值的集合
'
Private Function parseObject(ByRef str As String, ByRef Index As Long) As Object
Set parseObject = CreateObject("Scripting.Dictionary")
Dim sKey As String
' "{"
Call skipChar(str, Index)
If Mid(str, Index, 1) <> "{" Then
psErrors = psErrors & "Invalid Object at position " & Index & " : " & Mid(str, Index) & vbCrLf
Exit Function
End If
Index = Index + 1
Do
Call skipChar(str, Index)
If "}" = Mid(str, Index, 1) Then
Index = Index + 1
Exit Do
ElseIf "," = Mid(str, Index, 1) Then
Index = Index + 1
Call skipChar(str, Index)
ElseIf Index > Len(str) Then
psErrors = psErrors & "Missing '}': " & Right(str, 20) & vbCrLf
Exit Do
End If
' 添加键/值对
sKey = parseKey(str, Index)
On Error Resume Next
parseObject.Add sKey, parseValue(str, Index)
If ERR.Number <> 0 Then
psErrors = psErrors & ERR.Description & ": " & sKey & vbCrLf
Exit Do
End If
Loop
eh:
End Function
'
' 解析列表
'
Private Function parseArray(ByRef str As String, ByRef Index As Long) As Collection
Set parseArray = New Collection
' "["
Call skipChar(str, Index)
If Mid(str, Index, 1) <> "[" Then
psErrors = psErrors & "Invalid Array at position " & Index & " : " + Mid(str, Index, 20) & vbCrLf
Exit Function
End If
Index = Index + 1
Do
Call skipChar(str, Index)
If "]" = Mid(str, Index, 1) Then
Index = Index + 1
Exit Do
ElseIf "," = Mid(str, Index, 1) Then
Index = Index + 1
Call skipChar(str, Index)
ElseIf Index > Len(str) Then
psErrors = psErrors & "Missing ']': " & Right(str, 20) & vbCrLf
Exit Do
End If
' 添加值
On Error Resume Next
parseArray.Add parseValue(str, Index)
If ERR.Number <> 0 Then
psErrors = psErrors & ERR.Description & ": " & Mid(str, Index, 20) & vbCrLf
Exit Do
End If
Loop
End Function
'
' 解析字符串/数字/对象/数组/真/假/空
'
Private Function parseValue(ByRef str As String, ByRef Index As Long)
Call skipChar(str, Index)
Select Case Mid(str, Index, 1)
Case "{"
Set parseValue = parseObject(str, Index)
Case "["
Set parseValue = parseArray(str, Index)
Case """", "'"
parseValue = parseString(str, Index)
Case "t", "f"
parseValue = parseBoolean(str, Index)
Case "n"
parseValue = parseNull(str, Index)
Case Else
parseValue = parseNumber(str, Index)
End Select
End Function
'
' 解析字符串
'
Private Function parseString(ByRef str As String, ByRef Index As Long) As String
Dim quote As String
Dim Char As String
Dim Code As String
Dim SB As New cStringBuilder
Call skipChar(str, Index)
quote = Mid(str, Index, 1)
Index = Index + 1
Do While Index > 0 And Index <= Len(str)
Char = Mid(str, Index, 1)
Select Case (Char)
Case ""
Index = Index + 1
Char = Mid(str, Index, 1)
Select Case (Char)
Case """", "", "/", "'"
SB.Append Char
Index = Index + 1
Case "b"
SB.Append vbBack
Index = Index + 1
Case "f"
SB.Append vbFormFeed
Index = Index + 1
Case "n"
SB.Append vbLf
Index = Index + 1
Case "r"
SB.Append vbCr
Index = Index + 1
Case "t"
SB.Append vbTab
Index = Index + 1
Case "u"
Index = Index + 1
Code = Mid(str, Index, 4)
SB.Append ChrW(Val("&h" + Code))
Index = Index + 4
End Select
Case quote
Index = Index + 1
parseString = SB.toString
Set SB = Nothing
Exit Function
Case Else
SB.Append Char
Index = Index + 1
End Select
Loop
parseString = SB.toString
Set SB = Nothing
End Function
'
' 解析数字
'
Private Function parseNumber(ByRef str As String, ByRef Index As Long)
Dim Value As String
Dim Char As String
Call skipChar(str, Index)
Do While Index > 0 And Index <= Len(str)
Char = Mid(str, Index, 1)
If InStr("+-0123456789.eE", Char) Then
Value = Value & Char
Index = Index + 1
Else
parseNumber = CDec(Value)
Exit Function
End If
Loop
End Function
'
' 解析真/假
'
Private Function parseBoolean(ByRef str As String, ByRef Index As Long) As Boolean
Call skipChar(str, Index)
If Mid(str, Index, 4) = "true" Then
parseBoolean = True
Index = Index + 4
ElseIf Mid(str, Index, 5) = "false" Then
parseBoolean = False
Index = Index + 5
Else
psErrors = psErrors & "Invalid Boolean at position " & Index & " : " & Mid(str, Index) & vbCrLf
End If
End Function
'
' 解析空
'
Private Function parseNull(ByRef str As String, ByRef Index As Long)
Call skipChar(str, Index)
If Mid(str, Index, 4) = "null" Then
parseNull = Null
Index = Index + 4
Else
psErrors = psErrors & "Invalid null value at position " & Index & " : " & Mid(str, Index) & vbCrLf
End If
End Function
Private Function parseKey(ByRef str As String, ByRef Index As Long) As String
Dim dquote As Boolean
Dim squote As Boolean
Dim Char As String
Call skipChar(str, Index)
Do While Index > 0 And Index <= Len(str)
Char = Mid(str, Index, 1)
Select Case (Char)
Case """"
dquote = Not dquote
Index = Index + 1
If Not dquote Then
Call skipChar(str, Index)
If Mid(str, Index, 1) <> ":" Then
psErrors = psErrors & "Invalid Key at position " & Index & " : " & parseKey & vbCrLf
Exit Do
End If
End If
Case "'"
squote = Not squote
Index = Index + 1
If Not squote Then
Call skipChar(str, Index)
If Mid(str, Index, 1) <> ":" Then
psErrors = psErrors & "Invalid Key at position " & Index & " : " & parseKey & vbCrLf
Exit Do
End If
End If
Case ":"
Index = Index + 1
If Not dquote And Not squote Then
Exit Do
Else
parseKey = parseKey & Char
End If
Case Else
If InStr(vbCrLf & vbCr & vbLf & vbTab & " ", Char) Then
Else
parseKey = parseKey & Char
End If
Index = Index + 1
End Select
Loop
End Function
'
' 跳过特殊字符
'
Private Sub skipChar(ByRef str As String, ByRef Index As Long)
Dim bComment As Boolean
Dim bStartComment As Boolean
Dim bLongComment As Boolean
Do While Index > 0 And Index <= Len(str)
Select Case Mid(str, Index, 1)
Case vbCr, vbLf
If Not bLongComment Then
bStartComment = False
bComment = False
End If
Case vbTab, " ", "(", ")"
Case "/"
If Not bLongComment Then
If bStartComment Then
bStartComment = False
bComment = True
Else
bStartComment = True
bComment = False
bLongComment = False
End If
Else
If bStartComment Then
bLongComment = False
bStartComment = False
bComment = False
End If
End If
Case "*"
If bStartComment Then
bStartComment = False
bComment = True
bLongComment = True
Else
bStartComment = True
End If
Case Else
If Not bComment Then
Exit Do
End If
End Select
Index = Index + 1
Loop
End Sub
Public Function toString(ByRef obj As Variant) As String
Dim SB As New cStringBuilder
Select Case VarType(obj)
Case vbNull
SB.Append "null"
Case vbDate
SB.Append """" & CStr(obj) & """"
Case vbString
SB.Append """" & Encode(obj) & """"
Case vbObject
Dim bFI As Boolean
Dim i As Long
bFI = True
If TypeName(obj) = "Dictionary" Then
SB.Append "{"
Dim keys
keys = obj.keys
For i = 0 To obj.Count - 1
If bFI Then bFI = False Else SB.Append ","
Dim key
key = keys(i)
SB.Append """" & key & """:" & toString(obj.Item(key))
Next i
SB.Append "}"
ElseIf TypeName(obj) = "Collection" Then
SB.Append "["
Dim Value
For Each Value In obj
If bFI Then bFI = False Else SB.Append ","
SB.Append toString(Value)
Next Value
SB.Append "]"
End If
Case vbBoolean
If obj Then SB.Append "true" Else SB.Append "false"
Case vbVariant, vbArray, vbArray + vbVariant
Dim sEB
SB.Append multiArray(obj, 1, "", sEB)
Case Else
SB.Append Replace(obj, ",", ".")
End Select
toString = SB.toString
Set SB = Nothing
End Function
Private Function Encode(str) As String
Dim SB As New cStringBuilder
Dim i As Long
Dim j As Long
Dim aL1 As Variant
Dim aL2 As Variant
Dim c As String
Dim p As Boolean
aL1 = Array(&H22, &H5C, &H2F, &H8, &HC, &HA, &HD, &H9)
aL2 = Array(&H22, &H5C, &H2F, &H62, &H66, &H6E, &H72, &H74)
For i = 1 To Len(str)
p = True
c = Mid(str, i, 1)
For j = 0 To 7
If c = Chr(aL1(j)) Then
SB.Append "" & Chr(aL2(j))
p = False
Exit For
End If
Next
If p Then
Dim a
a = AscW(c)
If a > 31 And a < 127 Then
SB.Append c
ElseIf a > -1 Or a < 65535 Then
SB.Append "\u" & String(4 - Len(Hex(a)), "0") & Hex(a)
End If
End If
Next
Encode = SB.toString
Set SB = Nothing
End Function
Private Function multiArray(aBD, iBC, sPS, ByRef sPT)
Dim iDU As Long
Dim iDL As Long
Dim i As Long
On Error Resume Next
iDL = LBound(aBD, iBC)
iDU = UBound(aBD, iBC)
Dim SB As New cStringBuilder
Dim sPB1, sPB2 ' String PointBuffer1, String PointBuffer2
If ERR.Number = 9 Then
sPB1 = sPT & sPS
For i = 1 To Len(sPB1)
If i <> 1 Then sPB2 = sPB2 & ","
sPB2 = sPB2 & Mid(sPB1, i, 1)
Next
' multiArray = multiArray & toString(Eval("aBD(" & sPB2 & ")"))
SB.Append toString(aBD(sPB2))
Else
sPT = sPT & sPS
SB.Append "["
For i = iDL To iDU
SB.Append multiArray(aBD, iBC + 1, i, sPT)
If i < iDU Then SB.Append ","
Next
SB.Append "]"
sPT = Left(sPT, iBC - 2)
End If
ERR.Clear
multiArray = SB.toString
Set SB = Nothing
End Function
' Miscellaneous JSON functions
Public Function StringToJSON(st As String) As String
Const FIELD_SEP = "~"
Const RECORD_SEP = "|"
Dim sFlds As String
Dim sRecs As New cStringBuilder
Dim lRecCnt As Long
Dim lFld As Long
Dim fld As Variant
Dim rows As Variant
lRecCnt = 0
If st = "" Then
StringToJSON = "null"
Else
rows = Split(st, RECORD_SEP)
For lRecCnt = LBound(rows) To UBound(rows)
sFlds = ""
fld = Split(rows(lRecCnt), FIELD_SEP)
For lFld = LBound(fld) To UBound(fld) Step 2
sFlds = (sFlds & IIf(sFlds <> "", ",", "") & """" & fld(lFld) & """:""" & toUnicode(fld(lFld + 1) & "") & """")
Next 'fld
sRecs.Append IIf((Trim(sRecs.toString) <> ""), "," & vbCrLf, "") & "{" & sFlds & "}"
Next 'rec
StringToJSON = ("( {""Records"": [" & vbCrLf & sRecs.toString & vbCrLf & "], " & """RecordCount"":""" & lRecCnt & """ } )")
End If
End Function
Public Function toUnicode(str As String) As String
Dim X As Long
Dim uStr As New cStringBuilder
Dim uChrCode As Integer
For X = 1 To Len(str)
uChrCode = Asc(Mid(str, X, 1))
Select Case uChrCode
Case 8: ' backspace
uStr.Append "\b"
Case 9: ' tab
uStr.Append "\t"
Case 10: ' line feed
uStr.Append "\n"
Case 12: ' formfeed
uStr.Append "\f"
Case 13: ' carriage return
uStr.Append "\r"
Case 34: ' quote
uStr.Append """"
Case 39: ' apostrophe
uStr.Append "\'"
Case 92: ' backslash
uStr.Append "\"
Case 123, 125: ' "{" and "}"
uStr.Append ("\u" & Right("0000" & Hex(uChrCode), 4))
Case Is < 32, Is > 127: ' non-ascii characters
uStr.Append ("\u" & Right("0000" & Hex(uChrCode), 4))
Case Else
uStr.Append Chr$(uChrCode)
End Select
Next
toUnicode = uStr.toString
Exit Function
End Function
Private Sub Class_Initialize()
psErrors = ""
End Sub

复制代码

VTableSubclass.cls

Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, ByRef lpflOldProtect As Long) As Long
Private Const PAGE_EXECUTE_READWRITE As Long = &H40
Private PropRefCount As Long
Private PropVTableCount As Long
Private VTableHeaderPointer As Long
Private VTable() As Long, VTableOld() As Long
Private Sub Class_Terminate()
If VTableHeaderPointer <> 0 Then Call UnSubclass
End Sub
Public Property Get RefCount() As Long
RefCount = PropRefCount
End Property
Public Sub AddRef()
PropRefCount = PropRefCount + 1
End Sub
Public Sub Release()
PropRefCount = PropRefCount - 1
End Sub
Public Sub Subclass(ByVal ObjectPointer As Long, ByVal FirstEntry As Long, ByVal LastEntry As Long, ParamArray NewEntries() As Variant)
FirstEntry = FirstEntry - 1
Debug.Assert Not (FirstEntry < 0 Or FirstEntry > LastEntry Or LastEntry < 0 Or VTableHeaderPointer <> 0 Or ObjectPointer = 0)
CopyMemory VTableHeaderPointer, ByVal ObjectPointer, 4
PropVTableCount = LastEntry
ReDim VTable(0 To PropVTableCount)
ReDim VTableOld(0 To PropVTableCount)
Dim Entry As Long
Dim EntryPointer As Long
Entry = UBound(NewEntries()) + FirstEntry
If Entry > PropVTableCount Then Entry = PropVTableCount
EntryPointer = UnsignedAdd(VTableHeaderPointer, FirstEntry * 4)
For Entry = FirstEntry To Entry
VTable(Entry) = NewEntries(Entry - FirstEntry)
If VTable(Entry) <> 0 Then
Call CreateSubclass(EntryPointer, VTable(Entry), VTableOld(Entry))
End If
EntryPointer = UnsignedAdd(EntryPointer, 4)
Next Entry
End Sub
Public Property Get SubclassEntry(ByVal Entry As Long) As Boolean
Entry = Entry - 1
Debug.Assert Entry > -1 And Entry < PropVTableCount And VTableHeaderPointer <> 0
SubclassEntry = CBool(VTableOld(Entry))
End Property
Public Property Let SubclassEntry(ByVal Entry As Long, ByVal Value As Boolean)
Entry = Entry - 1
Dim EntryPointer As Long
Debug.Assert Entry >= 0 And Entry <= PropVTableCount And VTableHeaderPointer <> 0
If Me.SubclassEntry(Entry + 1) Xor Value Then
EntryPointer = UnsignedAdd(VTableHeaderPointer, Entry * 4)
If Value = True Then
Call CreateSubclass(EntryPointer, VTable(Entry), VTableOld(Entry))
Else
Call CreateSubclass(EntryPointer, VTableOld(Entry), 0)
VTableOld(Entry) = 0
End If
End If
End Property
Public Sub ReSubclass()
If VTableHeaderPointer <> 0 Then
Dim i As Long
For i = 0 To PropVTableCount
If VTableOld(i) <> 0 Then
Call CreateSubclass(UnsignedAdd(VTableHeaderPointer, i * 4), VTableOld(i), 0)
VTableOld(i) = 0
End If
Next i
For i = 0 To PropVTableCount
If VTable(i) <> 0 Then
Call CreateSubclass(UnsignedAdd(VTableHeaderPointer, i * 4), VTable(i), VTableOld(i))
End If
Next i
End If
End Sub
Public Sub UnSubclass()
If VTableHeaderPointer <> 0 Then
Dim i As Long
For i = 0 To PropVTableCount
If VTableOld(i) <> 0 Then
Call CreateSubclass(UnsignedAdd(VTableHeaderPointer, i * 4), VTableOld(i), 0)
VTableOld(i) = 0
End If
Next i
VTableHeaderPointer = 0
End If
End Sub
Private Sub CreateSubclass(ByVal EntryPointer As Long, ByVal NewPointer As Long, ByRef OldPointer As Long)
CopyMemory OldPointer, ByVal EntryPointer, 4
If OldPointer <> NewPointer Then
Dim OldProtect As Long
VirtualProtect EntryPointer, 4, PAGE_EXECUTE_READWRITE, OldProtect
CopyMemory ByVal EntryPointer, NewPointer, 4
VirtualProtect EntryPointer, 4, OldProtect, OldProtect
Else
' If you get this Assert then better restart the IDE.
' Known reasons:
' - End button was pushed.
' - Object has been modified while it is subclassed.
' Debug.Assert CBool(OldPointer <> NewPointer)
End If
End Sub

复制代码

ListBoxW.ctl

Option Explicit
#Const ImplementThemedButton = True
#If False Then
Private LstStyleStandard, LstStyleCheckbox, LstStyleOption
Private LstDrawModeNormal, LstDrawModeOwnerDrawFixed, LstDrawModeOwnerDrawVariable
#End If
Public Enum LstStyleConstants
LstStyleStandard = 0
LstStyleCheckbox = 1
LstStyleOption = 2
End Enum
Public Enum LstDrawModeConstants
LstDrawModeNormal = 0
LstDrawModeOwnerDrawFixed = 1
LstDrawModeOwnerDrawVariable = 2
End Enum
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type SIZEAPI
cx As Long
cy As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private 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 Integer
TMLastChar As Integer
TMDefaultChar As Integer
TMBreakChar As Integer
TMItalic As Byte
TMUnderlined As Byte
TMStruckOut As Byte
TMPitchAndFamily As Byte
TMCharset As Byte
End Type
Private Type MEASUREITEMSTRUCT
CtlType As Long
CtlID As Long
ItemID As Long
ItemWidth As Long
ItemHeight As Long
ItemData As Long
End Type
Private 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
Private Type SCROLLINFO
cbSize As Long
fMask As Long
nMin As Long
nMax As Long
nPage As Long
nPos As Long
nTrackPos As Long
End Type
Public Event Click()
Public Event DblClick()
Public Event Scroll()
Public Event ContextMenu(ByVal X As Single, ByVal Y As Single)
Public Event ItemBeforeCheck(ByVal Item As Long, ByRef Cancel As Boolean)
Public Event ItemCheck(ByVal Item As Long)
Public Event ItemMeasure(ByVal Item As Long, ByRef ItemHeight As Long)
Public Event ItemDraw(ByVal Item As Long, ByVal ItemAction As Long, ByVal ItemState As Long, ByVal hDC As Long, ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long)
Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean)
Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean)
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyChar As Integer)
Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseEnter()
Public Event MouseLeave()
Public Event OLECompleteDrag(Effect As Long)
Public Event OLEDragDrop(data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event OLEDragOver(data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean)
Public Event OLESetData(data As DataObject, DataFormat As Integer)
Public Event OLEStartDrag(data As DataObject, AllowedEffects As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As Long, ByVal lpWindowName As Long, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
Private Declare Function LBItemFromPt Lib "comctl32" (ByVal hLB As Long, ByVal PX As Long, ByVal PY As Long, ByVal bAutoScroll As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private 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
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) As Long
Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, ByVal lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorW" (ByVal hInstance As Long, ByVal lpCursorName As Any) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetScrollInfo Lib "user32" (ByVal hwnd As Long, ByVal wBar As Long, ByRef lpScrollInfo As SCROLLINFO) As Long
Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As Long
Private Declare Function DragDetect Lib "user32" (ByVal hwnd As Long, ByVal PX As Integer, ByVal PY As Integer) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32W" (ByVal hDC As Long, ByVal lpsz As Long, ByVal cbString As Long, ByRef lpSize As SIZEAPI) As Long
Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsW" (ByVal hDC As Long, ByRef lpMetrics As TEXTMETRIC) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As Any, ByVal bErase As Long) As Long
Private Declare Function CreateRectRgnIndirect Lib "gdi32" (ByRef lpRect As RECT) As Long
Private Declare Function ExtSelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long, ByVal fnMode As Long) As Long
Private Declare Function PatBlt Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function SetRect Lib "user32" (ByRef lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetTextAlign Lib "gdi32" (ByVal hDC As Long, ByVal fMode As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutW" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As Long, ByVal nCount As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hDC As Long, ByRef lpRect As RECT) As Long
Private Declare Function DrawFrameControl Lib "user32" (ByVal hDC As Long, ByRef lpRect As RECT, ByVal nCtlType As Long, ByVal nFlags As Long) As Long
#If ImplementThemedButton = True Then
Private Enum UxThemeButtonParts
BP_PUSHBUTTON = 1
BP_RADIOBUTTON = 2
BP_CHECKBOX = 3
BP_GROUPBOX = 4
BP_USERBUTTON = 5
End Enum
Private Enum UxThemeCheckBoxStates
CBS_UNCHECKEDNORMAL = 1
CBS_UNCHECKEDHOT = 2
CBS_UNCHECKEDPRESSED = 3
CBS_UNCHECKEDDISABLED = 4
CBS_CHECKEDNORMAL = 5
CBS_CHECKEDHOT = 6
CBS_CHECKEDPRESSED = 7
CBS_CHECKEDDISABLED = 8
End Enum
Private Enum UxThemeRadioButtonStates
RBS_UNCHECKEDNORMAL = 1
RBS_UNCHECKEDHOT = 2
RBS_UNCHECKEDPRESSED = 3
RBS_UNCHECKEDDISABLED = 4
RBS_CHECKEDNORMAL = 5
RBS_CHECKEDHOT = 6
RBS_CHECKEDPRESSED = 7
RBS_CHECKEDDISABLED = 8
End Enum
Private Declare Function IsThemeBackgroundPartiallyTransparent Lib "uxtheme" (ByVal Theme As Long, iPartId As Long, iStateId As Long) As Long
Private Declare Function DrawThemeParentBackground Lib "uxtheme" (ByVal hwnd As Long, ByVal hDC As Long, ByRef pRect As RECT) As Long
Private Declare Function DrawThemeBackground Lib "uxtheme" (ByVal Theme As Long, ByVal hDC As Long, ByVal iPartId As Long, ByVal iStateId As Long, ByRef pRect As RECT, ByRef pClipRect As RECT) As Long
Private Declare Function OpenThemeData Lib "uxtheme" (ByVal hwnd As Long, ByVal pszClassList As Long) As Long
Private Declare Function CloseThemeData Lib "uxtheme" (ByVal Theme As Long) As Long
#End If
Private Const ICC_STANDARD_CLASSES As Long = &H4000
Private Const RDW_UPDATENOW As Long = &H100, RDW_INVALIDATE As Long = &H1, RDW_ERASE As Long = &H4, RDW_ALLCHILDREN As Long = &H80
Private Const GWL_STYLE As Long = (-16)
Private Const CF_UNICODETEXT As Long = 13
Private Const TA_RTLREADING = &H100, TA_RIGHT As Long = &H2
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_CHILD As Long = &H40000000
Private Const WS_EX_RTLREADING As Long = &H2000, WS_EX_RIGHT As Long = &H1000, WS_EX_LEFTSCROLLBAR As Long = &H4000
Private Const SW_HIDE As Long = &H0
Private Const WM_MOUSEACTIVATE As Long = &H21, MA_ACTIVATE As Long = &H1, MA_ACTIVATEANDEAT As Long = &H2, MA_NOACTIVATE As Long = &H3, MA_NOACTIVATEANDEAT As Long = &H4, HTBORDER As Long = 18
Private Const WM_MOUSEWHEEL As Long = &H20A
Private Const WM_SETFOCUS As Long = &H7
Private Const WM_KILLFOCUS As Long = &H8
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const WM_CHAR As Long = &H102
Private Const WM_SYSKEYDOWN As Long = &H104
Private Const WM_SYSKEYUP As Long = &H105
Private Const WM_UNICHAR As Long = &H109, UNICODE_NOCHAR As Long = &HFFFF&
Private Const WM_IME_CHAR As Long = &H286
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const WM_LBUTTONUP As Long = &H202
Private Const WM_MBUTTONDOWN As Long = &H207
Private Const WM_MBUTTONUP As Long = &H208
Private Const WM_RBUTTONDOWN As Long = &H204
Private Const WM_RBUTTONUP As Long = &H205
Private Const WM_MOUSEMOVE As Long = &H200
Private Const WM_MOUSELEAVE As Long = &H2A3
Private Const WM_COMMAND As Long = &H111
Private Const WM_SETREDRAW As Long = &HB
Private Const WM_CONTEXTMENU As Long = &H7B
Private Const WM_MEASUREITEM As Long = &H2C
Private Const WM_DRAWITEM As Long = &H2B, ODT_LISTBOX As Long = &H2, ODS_SELECTED As Long = &H1, ODS_DISABLED As Long = &H4, ODS_FOCUS As Long = &H10
Private Const WM_DESTROY As Long = &H2
Private Const WM_NCDESTROY As Long = &H82
Private Const WM_STYLECHANGED As Long = &H7D
Private Const WM_SETFONT As Long = &H30
Private Const WM_SETCURSOR As Long = &H20, HTCLIENT As Long = 1
Private Const WM_PAINT As Long = &HF
Private Const WS_HSCROLL As Long = &H100000
Private Const WS_VSCROLL As Long = &H200000
Private Const WM_VSCROLL As Long = &H115
Private Const WM_HSCROLL As Long = &H114
Private Const SB_HORZ As Long = 0
Private Const SB_VERT As Long = 1
Private Const SB_THUMBPOSITION = 4, SB_THUMBTRACK As Long = 5
Private Const SB_LINELEFT As Long = 0, SB_LINERIGHT As Long = 1
Private Const SB_LINEUP As Long = 0, SB_LINEDOWN As Long = 1
Private Const SIF_POS As Long = &H4
Private Const SIF_TRACKPOS As Long = &H10
Private Const RGN_COPY As Long = 5
Private Const DFC_BUTTON As Long = &H4, DFCS_BUTTONCHECK As Long = &H0, DFCS_BUTTONRADIO As Long = &H4, DFCS_INACTIVE As Long = &H100, DFCS_CHECKED As Long = &H400, DFCS_FLAT As Long = &H4000
Private Const LB_ERR As Long = (-1)
Private Const LB_ADDSTRING As Long = &H180
Private Const LB_INSERTSTRING As Long = &H181
Private Const LB_DELETESTRING As Long = &H182
Private Const LB_SELITEMRANGEEX As Long = &H183
Private Const LB_RESETCONTENT As Long = &H184
Private Const LB_SETSEL As Long = &H185
Private Const LB_SETCURSEL As Long = &H186
Private Const LB_GETSEL As Long = &H187
Private Const LB_GETCURSEL As Long = &H188
Private Const LB_GETTEXT As Long = &H189
Private Const LB_GETTEXTLEN As Long = &H18A
Private Const LB_GETCOUNT As Long = &H18B
Private Const LB_SELECTSTRING As Long = &H18C
Private Const LB_DIR As Long = &H18D
Private Const LB_GETTOPINDEX As Long = &H18E
Private Const LB_FINDSTRING As Long = &H18F
Private Const LB_GETSELCOUNT As Long = &H190
Private Const LB_GETSELITEMS As Long = &H191
Private Const LB_SETTABSTOPS As Long = &H192
Private Const LB_GETHORIZONTALEXTENT As Long = &H193
Private Const LB_SETHORIZONTALEXTENT As Long = &H194
Private Const LB_SETCOLUMNWIDTH As Long = &H195
Private Const LB_ADDFILE As Long = &H196
Private Const LB_SETTOPINDEX As Long = &H197
Private Const LB_GETITEMRECT As Long = &H198
Private Const LB_GETITEMDATA As Long = &H199
Private Const LB_SETITEMDATA As Long = &H19A
Private Const LB_SELITEMRANGE As Long = &H19B ' 16 bit
Private Const LB_SETANCHORINDEX As Long = &H19C
Private Const LB_GETANCHORINDEX As Long = &H19D
Private Const LB_SETCARETINDEX As Long = &H19E
Private Const LB_GETCARETINDEX As Long = &H19F
Private Const LB_SETITEMHEIGHT As Long = &H1A0
Private Const LB_GETITEMHEIGHT As Long = &H1A1
Private Const LB_FINDSTRINGEXACT As Long = &H1A2
Private Const LB_SETLOCALE As Long = &H1A5
Private Const LB_GETLOCALE As Long = &H1A6
Private Const LB_SETCOUNT As Long = &H1A7
Private Const LB_INITSTORAGE As Long = &H1A8
Private Const LB_ITEMFROMPOINT As Long = &H1A9 ' 16 bit
Private Const LB_GETLISTBOXINFO As Long = &H1B2
Private Const LBS_NOTIFY As Long = &H1
Private Const LBS_SORT As Long = &H2
Private Const LBS_NOREDRAW As Long = &H4
Private Const LBS_MULTIPLESEL As Long = &H8
Private Const LBS_OWNERDRAWFIXED As Long = &H10
Private Const LBS_OWNERDRAWVARIABLE As Long = &H20
Private Const LBS_HASSTRINGS As Long = &H40
Private Const LBS_USETABSTOPS As Long = &H80
Private Const LBS_NOINTEGRALHEIGHT As Long = &H100
Private Const LBS_MULTICOLUMN As Long = &H200
Private Const LBS_WANTKEYBOARDINPUT As Long = &H400
Private Const LBS_EXTENDEDSEL As Long = &H800
Private Const LBS_DISABLENOSCROLL As Long = &H1000
Private Const LBS_NODATA As Long = &H2000
Private Const LBS_NOSEL As Long = &H4000
Private Const LBN_ERRSPACE As Long = (-2)
Private Const LBN_SELCHANGE As Long = 1
Private Const LBN_DBLCLK As Long = 2
Private Const LBN_SELCANCEL As Long = 3
Private Const LBN_SETFOCUS As Long = 4
Private Const LBN_KILLFOCUS As Long = 5
Implements ISubclass
Implements OLEGuids.IObjectSafety
Implements OLEGuids.IOleInPlaceActiveObjectVB
Implements OLEGuids.IPerPropertyBrowsingVB
Private ListBoxHandle As Long
Private ListBoxFontHandle As Long
Private ListBoxCharCodeCache As Long
Private ListBoxMouseOver As Boolean
Private ListBoxDesignMode As Boolean, ListBoxTopDesignMode As Boolean
Private ListBoxNewIndex As Long
Private ListBoxDragIndexBuffer As Long, ListBoxDragIndex As Long
Private ListBoxTopIndex As Long
Private ListBoxInsertMark As Long, ListBoxInsertMarkAfter As Boolean
Private ListBoxItemCheckedCount As Long
Private ListBoxItemChecked() As Byte, ListBoxOptionIndex As Long
Private ListBoxStateImageSize As Long
Private DispIDMousePointer As Long
Private WithEvents PropFont As StdFont
Private PropVisualStyles As Boolean
Private PropOLEDragMode As VBRUN.OLEDragConstants
Private PropOLEDragDropScroll As Boolean
Private PropMousePointer As Integer, PropMouseIcon As IPictureDisp
Private PropMouseTrack As Boolean
Private PropRightToLeft As Boolean
Private PropRightToLeftMode As CCRightToLeftModeConstants
Private PropRedraw As Boolean
Private PropBorderStyle As CCBorderStyleConstants
Private PropMultiColumn As Boolean
Private PropSorted As Boolean
Private PropIntegralHeight As Boolean
Private PropAllowSelection As Boolean
Private PropMultiSelect As VBRUN.MultiSelectConstants
Private PropHorizontalExtent As Long
Private PropUseTabStops As Boolean
Private PropStyle As LstStyleConstants
Private PropDisableNoScroll As Boolean
Private PropDrawMode As LstDrawModeConstants
Private PropInsertMarkColor As OLE_COLOR
Private PropScrollTrack As Boolean
Private Sub IObjectSafety_GetInterfaceSafetyOptions(ByRef riid As OLEGuids.OLECLSID, ByRef pdwSupportedOptions As Long, ByRef pdwEnabledOptions As Long)
Const INTERFACESAFE_FOR_UNTRUSTED_CALLER As Long = &H1, INTERFACESAFE_FOR_UNTRUSTED_DATA As Long = &H2
pdwSupportedOptions = INTERFACESAFE_FOR_UNTRUSTED_CALLER Or INTERFACESAFE_FOR_UNTRUSTED_DATA
pdwEnabledOptions = INTERFACESAFE_FOR_UNTRUSTED_CALLER Or INTERFACESAFE_FOR_UNTRUSTED_DATA
End Sub
Private Sub IObjectSafety_SetInterfaceSafetyOptions(ByRef riid As OLEGuids.OLECLSID, ByVal dwOptionsSetMask As Long, ByVal dwEnabledOptions As Long)
End Sub
Private Sub IOleInPlaceActiveObjectVB_TranslateAccelerator(ByRef Handled As Boolean, ByRef RetVal As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal Shift As Long)
If wMsg = WM_KEYDOWN Or wMsg = WM_KEYUP Then
Dim KeyCode As Integer, IsInputKey As Boolean
KeyCode = wParam And &HFF&
If wMsg = WM_KEYDOWN Then
RaiseEvent PreviewKeyDown(KeyCode, IsInputKey)
ElseIf wMsg = WM_KEYUP Then
RaiseEvent PreviewKeyUp(KeyCode, IsInputKey)
End If
Select Case KeyCode
Case vbKeyUp, vbKeyDown, vbKeyLeft, vbKeyRight, vbKeyPageDown, vbKeyPageUp, vbKeyHome, vbKeyEnd
If ListBoxHandle <> 0 Then
SendMessage ListBoxHandle, wMsg, wParam, ByVal lParam
Handled = True
End If
Case vbKeyTab, vbKeyReturn, vbKeyEscape
If IsInputKey = True Then
If ListBoxHandle <> 0 Then
SendMessage ListBoxHandle, wMsg, wParam, ByVal lParam
Handled = True
End If
End If
End Select
End If
End Sub
Private Sub IPerPropertyBrowsingVB_GetDisplayString(ByRef Handled As Boolean, ByVal DispID As Long, ByRef DisplayName As String)
If DispID = DispIDMousePointer Then
Call ComCtlsIPPBSetDisplayStringMousePointer(PropMousePointer, DisplayName)
Handled = True
End If
End Sub
Private Sub IPerPropertyBrowsingVB_GetPredefinedStrings(ByRef Handled As Boolean, ByVal DispID As Long, ByRef StringsOut() As String, ByRef CookiesOut() As Long)
If DispID = DispIDMousePointer Then
Call ComCtlsIPPBSetPredefinedStringsMousePointer(StringsOut(), CookiesOut())
Handled = True
End If
End Sub
Private Sub IPerPropertyBrowsingVB_GetPredefinedValue(ByRef Handled As Boolean, ByVal DispID As Long, ByVal Cookie As Long, ByRef Value As Variant)
If DispID = DispIDMousePointer Then
Value = Cookie
Handled = True
End If
End Sub
Private Sub UserControl_Initialize()
Call ComCtlsLoadShellMod
Call ComCtlsInitCC(ICC_STANDARD_CLASSES)
Call SetVTableSubclass(Me, VTableInterfaceInPlaceActiveObject)
Call SetVTableSubclass(Me, VTableInterfacePerPropertyBrowsing)
ReDim ListBoxItemChecked(0) As Byte
ListBoxStateImageSize = (15 * PixelsPerDIP_X())
End Sub
Private Sub UserControl_InitProperties()
If DispIDMousePointer = 0 Then DispIDMousePointer = GetDispID(Me, "MousePointer")
On Error Resume Next
ListBoxDesignMode = Not Ambient.UserMode
ListBoxTopDesignMode = Not GetTopUserControl(Me).Ambient.UserMode
On Error GoTo 0
Set PropFont = Ambient.Font
PropVisualStyles = True
PropOLEDragMode = vbOLEDragManual
PropOLEDragDropScroll = True
Me.OLEDropMode = vbOLEDropNone
PropMousePointer = 0: Set PropMouseIcon = Nothing
PropMouseTrack = False
PropRightToLeft = Ambient.RightToLeft
PropRightToLeftMode = CCRightToLeftModeVBAME
If PropRightToLeft = True Then Me.RightToLeft = True
PropRedraw = True
PropBorderStyle = CCBorderStyleSunken
PropSorted = False
PropIntegralHeight = True
PropAllowSelection = True
PropMultiSelect = vbMultiSelectNone
PropHorizontalExtent = 0
PropUseTabStops = True
PropStyle = vbListBoxStandard
PropDisableNoScroll = False
PropDrawMode = LstDrawModeNormal
PropInsertMarkColor = vbBlack
PropScrollTrack = True
Call CreateListBox
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
If DispIDMousePointer = 0 Then DispIDMousePointer = GetDispID(Me, "MousePointer")
On Error Resume Next
ListBoxDesignMode = Not Ambient.UserMode
ListBoxTopDesignMode = Not GetTopUserControl(Me).Ambient.UserMode
On Error GoTo 0
With PropBag
Set PropFont = .ReadProperty("Font", Nothing)
PropVisualStyles = .ReadProperty("VisualStyles", True)
Me.BackColor = .ReadProperty("BackColor", vbButtonFace)
Me.ForeColor = .ReadProperty("ForeColor", vbButtonText)
Me.Enabled = .ReadProperty("Enabled", True)
PropOLEDragMode = .ReadProperty("OLEDragMode", vbOLEDragManual)
PropOLEDragDropScroll = .ReadProperty("OLEDragDropScroll", True)
Me.OLEDropMode = .ReadProperty("OLEDropMode", vbOLEDropNone)
PropMousePointer = .ReadProperty("MousePointer", 0)
Set PropMouseIcon = .ReadProperty("MouseIcon", Nothing)
PropMouseTrack = .ReadProperty("MouseTrack", False)
PropRightToLeft = .ReadProperty("RightToLeft", False)
PropRightToLeftMode = .ReadProperty("RightToLeftMode", CCRightToLeftModeVBAME)
If PropRightToLeft = True Then Me.RightToLeft = True
PropRedraw = .ReadProperty("Redraw", True)
PropBorderStyle = .ReadProperty("BorderStyle", CCBorderStyleSunken)
PropMultiColumn = .ReadProperty("MultiColumn", False)
PropSorted = .ReadProperty("Sorted", False)
PropIntegralHeight = .ReadProperty("IntegralHeight", True)
PropAllowSelection = .ReadProperty("AllowSelection", True)
PropMultiSelect = .ReadProperty("MultiSelect", vbMultiSelectNone)
PropHorizontalExtent = .ReadProperty("HorizontalExtent", 0)
PropUseTabStops = .ReadProperty("UseTabStops", True)
PropStyle = .ReadProperty("Style", vbListBoxStandard)
PropDisableNoScroll = .ReadProperty("DisableNoScroll", False)
PropDrawMode = .ReadProperty("DrawMode", LstDrawModeNormal)
PropInsertMarkColor = .ReadProperty("InsertMarkColor", vbBlack)
PropScrollTrack = .ReadProperty("ScrollTrack", True)
End With
Call CreateListBox
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
With PropBag
.WriteProperty "Font", IIf(OLEFontIsEqual(PropFont, Ambient.Font) = False, PropFont, Nothing), Nothing
.WriteProperty "VisualStyles", PropVisualStyles, True
.WriteProperty "BackColor", Me.BackColor, vbButtonFace
.WriteProperty "ForeColor", Me.ForeColor, vbButtonText
.WriteProperty "Enabled", Me.Enabled, True
.WriteProperty "OLEDragMode", PropOLEDragMode, vbOLEDragManual
.WriteProperty "OLEDragDropScroll", PropOLEDragDropScroll, True
.WriteProperty "OLEDropMode", Me.OLEDropMode, vbOLEDropNone
.WriteProperty "MousePointer", PropMousePointer, 0
.WriteProperty "MouseIcon", PropMouseIcon, Nothing
.WriteProperty "MouseTrack", PropMouseTrack, False
.WriteProperty "RightToLeft", PropRightToLeft, False
.WriteProperty "RightToLeftMode", PropRightToLeftMode, CCRightToLeftModeVBAME
.WriteProperty "Redraw", PropRedraw, True
.WriteProperty "BorderStyle", PropBorderStyle, CCBorderStyleSunken
.WriteProperty "MultiColumn", PropMultiColumn, False
.WriteProperty "Sorted", PropSorted, False
.WriteProperty "IntegralHeight", PropIntegralHeight, True
.WriteProperty "AllowSelection", PropAllowSelection, True
.WriteProperty "MultiSelect", PropMultiSelect, vbMultiSelectNone
.WriteProperty "HorizontalExtent", PropHorizontalExtent, 0
.WriteProperty "UseTabStops", PropUseTabStops, True
.WriteProperty "Style", PropStyle, vbListBoxStandard
.WriteProperty "DisableNoScroll", PropDisableNoScroll, False
.WriteProperty "DrawMode", PropDrawMode, LstDrawModeNormal
.WriteProperty "InsertMarkColor", PropInsertMarkColor, vbBlack
.WriteProperty "ScrollTrack", PropScrollTrack, True
End With
End Sub
Private Sub UserControl_OLECompleteDrag(Effect As Long)
RaiseEvent OLECompleteDrag(Effect)
ListBoxDragIndex = 0
End Sub
Private Sub UserControl_OLEDragDrop(data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent OLEDragDrop(data, Effect, Button, Shift, UserControl.ScaleX(X, vbPixels, vbContainerPosition), UserControl.ScaleY(Y, vbPixels, vbContainerPosition))
End Sub
Private Sub UserControl_OLEDragOver(data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
RaiseEvent OLEDragOver(data, Effect, Button, Shift, UserControl.ScaleX(X, vbPixels, vbContainerPosition), UserControl.ScaleY(Y, vbPixels, vbContainerPosition), State)
If ListBoxHandle <> 0 Then
If State = vbOver And Not Effect = vbDropEffectNone Then
If PropOLEDragDropScroll = True Then
Dim RC As RECT
GetWindowRect ListBoxHandle, RC
Dim dwStyle As Long
dwStyle = GetWindowLong(ListBoxHandle, GWL_STYLE)
If (dwStyle And WS_HSCROLL) = WS_HSCROLL Then
If Abs(X) < (16 * PixelsPerDIP_X()) Then
SendMessage ListBoxHandle, WM_HSCROLL, SB_LINELEFT, ByVal 0&
ElseIf Abs(X - (RC.Right - RC.Left)) < (16 * PixelsPerDIP_X()) Then
SendMessage ListBoxHandle, WM_HSCROLL, SB_LINERIGHT, ByVal 0&
End If
End If
If (dwStyle And WS_VSCROLL) = WS_VSCROLL Then
If Abs(Y) < (16 * PixelsPerDIP_Y()) Then
SendMessage ListBoxHandle, WM_VSCROLL, SB_LINEUP, ByVal 0&
ElseIf Abs(Y - (RC.Bottom - RC.Top)) < (16 * PixelsPerDIP_Y()) Then
SendMessage ListBoxHandle, WM_VSCROLL, SB_LINEDOWN, ByVal 0&
End If
End If
End If
End If
End If
End Sub
Private Sub UserControl_OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean)
RaiseEvent OLEGiveFeedback(Effect, DefaultCursors)
End Sub
Private Sub UserControl_OLESetData(data As DataObject, DataFormat As Integer)
RaiseEvent OLESetData(data, DataFormat)
End Sub
Private Sub UserControl_OLEStartDrag(data As DataObject, AllowedEffects As Long)
If ListBoxDragIndex > 0 Then
If PropOLEDragMode = vbOLEDragAutomatic Then
Dim SelIndices As Collection, Text As String
Set SelIndices = Me.SelectedIndices
With SelIndices
If .Count > 0 Then
Dim Item As Variant, i As Long
For Each Item In SelIndices
i = i + 1
Text = Text & Me.List(Item) & IIf(i < .Count, vbCrLf, vbNullString)
Next Item
End If
End With
data.SetData StrToVar(Text & vbNullChar), CF_UNICODETEXT
data.SetData StrToVar(Text), vbCFText
AllowedEffects = vbDropEffectCopy
End If
ElseIf ListBoxHandle <> 0 Then
Dim p As POINTAPI
GetCursorPos p
ListBoxDragIndex = LBItemFromPt(ListBoxHandle, p.X, p.Y, 0) + 1
End If
RaiseEvent OLEStartDrag(data, AllowedEffects)
If AllowedEffects = vbDropEffectNone Then ListBoxDragIndex = 0
End Sub
Public Sub OLEDrag()
If ListBoxDragIndex > 0 Then Exit Sub
If ListBoxDragIndexBuffer > 0 Then ListBoxDragIndex = ListBoxDragIndexBuffer
UserControl.OLEDrag
End Sub
Private Sub UserControl_AmbientChanged(PropertyName As String)
If ListBoxDesignMode = True And PropertyName = "DisplayName" Then
If ListBoxHandle <> 0 Then
If SendMessage(ListBoxHandle, LB_GETCOUNT, 0, ByVal 0&) > 0 Then
Dim Buffer As String
Buffer = Ambient.DisplayName
SendMessage ListBoxHandle, LB_RESETCONTENT, 0, ByVal 0&
SendMessage ListBoxHandle, LB_ADDSTRING, 0, ByVal StrPtr(Buffer)
SendMessage ListBoxHandle, LB_SETCURSEL, -1, ByVal 0&
End If
End If
End If
End Sub
Private Sub UserControl_Resize()
Static InProc As Boolean
If InProc = True Then Exit Sub
InProc = True
With UserControl
If DPICorrectionFactor() <> 1 Then Call SyncObjectRectsToContainer(Me)
If ListBoxHandle = 0 Then InProc = False: Exit Sub
Dim WndRect As RECT
MoveWindow ListBoxHandle, 0, 0, .ScaleWidth, .ScaleHeight, 1
If PropIntegralHeight = True Then
GetWindowRect ListBoxHandle, WndRect
.Extender.Height = .ScaleY((WndRect.Bottom - WndRect.Top), vbPixels, vbContainerSize)
End If
If DPICorrectionFactor() <> 1 Then Call SyncObjectRectsToContainer(Me)
End With
InProc = False
End Sub
Private Sub UserControl_Terminate()
Call RemoveVTableSubclass(Me, VTableInterfaceInPlaceActiveObject)
Call RemoveVTableSubclass(Me, VTableInterfacePerPropertyBrowsing)
Call DestroyListBox
Call ComCtlsReleaseShellMod
End Sub
Public Property Get Name() As String
Name = Ambient.DisplayName
End Property
Public Property Get Tag() As String
Tag = Extender.Tag
End Property
Public Property Let Tag(ByVal Value As String)
Extender.Tag = Value
End Property
Public Property Get Parent() As Object
Set Parent = UserControl.Parent
End Property
Public Property Get Container() As Object
Set Container = Extender.Container
End Property
Public Property Set Container(ByVal Value As Object)
Set Extender.Container = Value
End Property
Public Property Get Left() As Single
Left = Extender.Left
End Property
Public Property Let Left(ByVal Value As Single)
Extender.Left = Value
End Property
Public Property Get Top() As Single
Top = Extender.Top
End Property
Public Property Let Top(ByVal Value As Single)
Extender.Top = Value
End Property
Public Property Get Width() As Single
Width = Extender.Width
End Property
Public Property Let Width(ByVal Value As Single)
Extender.Width = Value
End Property
Public Property Get Height() As Single
Height = Extender.Height
End Property
Public Property Let Height(ByVal Value As Single)
Extender.Height = Value
End Property
Public Property Get Visible() As Boolean
Visible = Extender.Visible
End Property
Public Property Let Visible(ByVal Value As Boolean)
Extender.Visible = Value
End Property
Public Property Get ToolTipText() As String
ToolTipText = Extender.ToolTipText
End Property
Public Property Let ToolTipText(ByVal Value As String)
Extender.ToolTipText = Value
End Property
Public Property Get HelpContextID() As Long
HelpContextID = Extender.HelpContextID
End Property
Public Property Let HelpContextID(ByVal Value As Long)
Extender.HelpContextID = Value
End Property
Public Property Get WhatsThisHelpID() As Long
WhatsThisHelpID = Extender.WhatsThisHelpID
End Property
Public Property Let WhatsThisHelpID(ByVal Value As Long)
Extender.WhatsThisHelpID = Value
End Property
Public Property Get DragIcon() As IPictureDisp
Set DragIcon = Extender.DragIcon
End Property
Public Property Let DragIcon(ByVal Value As IPictureDisp)
Extender.DragIcon = Value
End Property
Public Property Set DragIcon(ByVal Value As IPictureDisp)
Set Extender.DragIcon = Value
End Property
Public Property Get DragMode() As Integer
DragMode = Extender.DragMode
End Property
Public Property Let DragMode(ByVal Value As Integer)
Extender.DragMode = Value
End Property
Public Sub Drag(Optional ByRef Action As Variant)
If IsMissing(Action) Then Extender.Drag Else Extender.Drag Action
End Sub
Public Sub SetFocus()
Extender.SetFocus
End Sub
Public Sub ZOrder(Optional ByRef Position As Variant)
If IsMissing(Position) Then Extender.ZOrder Else Extender.ZOrder Position
End Sub
Public Property Get hwnd() As Long
hwnd = ListBoxHandle
End Property
Public Property Get hWndUserControl() As Long
hWndUserControl = UserControl.hwnd
End Property
Public Property Get Font() As StdFont
Set Font = PropFont
End Property
Public Property Let Font(ByVal NewFont As StdFont)
Set Me.Font = NewFont
End Property
Public Property Set Font(ByVal NewFont As StdFont)
If NewFont Is Nothing Then Set NewFont = Ambient.Font
Dim OldFontHandle As Long
Set PropFont = NewFont
OldFontHandle = ListBoxFontHandle
ListBoxFontHandle = CreateGDIFontFromOLEFont(PropFont)
If ListBoxHandle <> 0 Then SendMessage ListBoxHandle, WM_SETFONT, ListBoxFontHandle, ByVal 1&
If OldFontHandle <> 0 Then DeleteObject OldFontHandle
If PropStyle <> LstStyleStandard And ListBoxHandle <> 0 Then
Dim hDCScreen As Long
hDCScreen = GetDC(0)
If hDCScreen <> 0 Then
Dim TM As TEXTMETRIC, hFontOld As Long
If ListBoxFontHandle <> 0 Then hFontOld = SelectObject(hDCScreen, ListBoxFontHandle)
If GetTextMetrics(hDCScreen, TM) <> 0 Then
If TM.TMHeight < ListBoxStateImageSize Then TM.TMHeight = ListBoxStateImageSize
SendMessage ListBoxHandle, LB_SETITEMHEIGHT, 0, ByVal TM.TMHeight
If PropIntegralHeight = True Then
MoveWindow ListBoxHandle, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight + 1, 0
MoveWindow ListBoxHandle, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight, 0
End If
End If
If hFontOld <> 0 Then SelectObject hDCScreen, hFontOld
ReleaseDC 0, hDCScreen
End If
End If
Call UserControl_Resize
UserControl.PropertyChanged "Font"
End Property
Private Sub PropFont_FontChanged(ByVal PropertyName As String)
Dim OldFontHandle As Long
OldFontHandle = ListBoxFontHandle
ListBoxFontHandle = CreateGDIFontFromOLEFont(PropFont)
If ListBoxHandle <> 0 Then SendMessage ListBoxHandle, WM_SETFONT, ListBoxFontHandle, ByVal 1&
If OldFontHandle <> 0 Then DeleteObject OldFontHandle
If PropStyle <> LstStyleStandard And ListBoxHandle <> 0 Then
Dim hDCScreen As Long
hDCScreen = GetDC(0)
If hDCScreen <> 0 Then
Dim TM As TEXTMETRIC, hFontOld As Long
If ListBoxFontHandle <> 0 Then hFontOld = SelectObject(hDCScreen, ListBoxFontHandle)
If GetTextMetrics(hDCScreen, TM) <> 0 Then
If TM.TMHeight < ListBoxStateImageSize Then TM.TMHeight = ListBoxStateImageSize
SendMessage ListBoxHandle, LB_SETITEMHEIGHT, 0, ByVal TM.TMHeight
If PropIntegralHeight = True Then
MoveWindow ListBoxHandle, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight + 1, 0
MoveWindow ListBoxHandle, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight, 0
End If
End If
If hFontOld <> 0 Then SelectObject hDCScreen, hFontOld
ReleaseDC 0, hDCScreen
End If
End If
Call UserControl_Resize
UserControl.PropertyChanged "Font"
End Sub
Public Property Get VisualStyles() As Boolean
VisualStyles = PropVisualStyles
End Property
Public Property Let VisualStyles(ByVal Value As Boolean)
PropVisualStyles = Value
If ListBoxHandle <> 0 And EnabledVisualStyles() = True Then
If PropVisualStyles = True Then
ActivateVisualStyles ListBoxHandle
Else
RemoveVisualStyles ListBoxHandle
End If
Me.Refresh
End If
UserControl.PropertyChanged "VisualStyles"
End Property
Public Property Get BackColor() As OLE_COLOR
BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal Value As OLE_COLOR)
UserControl.BackColor = Value
Me.Refresh
UserControl.PropertyChanged "BackColor"
End Property
Public Property Get ForeColor() As OLE_COLOR
ForeColor = UserControl.ForeColor
End Property
Public Property Let ForeColor(ByVal Value As OLE_COLOR)
UserControl.ForeColor = Value
Me.Refresh
UserControl.PropertyChanged "ForeColor"
End Property
Public Property Get Enabled() As Boolean
Enabled = UserControl.Enabled
End Property
Public Property Let Enabled(ByVal Value As Boolean)
UserControl.Enabled = Value
If ListBoxHandle <> 0 Then EnableWindow ListBoxHandle, IIf(Value = True, 1, 0)
UserControl.PropertyChanged "Enabled"
End Property
Public Property Get OLEDragMode() As VBRUN.OLEDragConstants
OLEDragMode = PropOLEDragMode
End Property
Public Property Let OLEDragMode(ByVal Value As VBRUN.OLEDragConstants)
Select Case Value
Case vbOLEDragManual, vbOLEDragAutomatic
PropOLEDragMode = Value
Case Else
ERR.Raise 380
End Select
UserControl.PropertyChanged "OLEDragMode"
End Property
Public Property Get OLEDragDropScroll() As Boolean
OLEDragDropScroll = PropOLEDragDropScroll
End Property
Public Property Let OLEDragDropScroll(ByVal Value As Boolean)
PropOLEDragDropScroll = Value
UserControl.PropertyChanged "OLEDragDropScroll"
End Property
Public Property Get OLEDropMode() As OLEDropModeConstants
OLEDropMode = UserControl.OLEDropMode
End Property
Public Property Let OLEDropMode(ByVal Value As OLEDropModeConstants)
Select Case Value
Case OLEDropModeNone, OLEDropModeManual
UserControl.OLEDropMode = Value
Case Else
ERR.Raise 380
End Select
UserControl.PropertyChanged "OLEDropMode"
End Property
Public Property Get MousePointer() As Integer
MousePointer = PropMousePointer
End Property
Public Property Let MousePointer(ByVal Value As Integer)
Select Case Value
Case 0 To 16, 99
PropMousePointer = Value
Case Else
ERR.Raise 380
End Select
UserControl.PropertyChanged "MousePointer"
End Property
Public Property Get MouseIcon() As IPictureDisp
Set MouseIcon = PropMouseIcon
End Property
Public Property Let MouseIcon(ByVal Value As IPictureDisp)
Set Me.MouseIcon = Value
End Property
Public Property Set MouseIcon(ByVal Value As IPictureDisp)
If Value Is Nothing Then
Set PropMouseIcon = Nothing
Else
If Value.Type = vbPicTypeIcon Or Value.Handle = 0 Then
Set PropMouseIcon = Value
Else
If ListBoxDesignMode = True Then
MsgBox "Invalid property value", vbCritical + vbOKOnly
Exit Property
Else
ERR.Raise 380
End If
End If
End If
UserControl.PropertyChanged "MouseIcon"
End Property
Public Property Get MouseTrack() As Boolean
MouseTrack = PropMouseTrack
End Property
Public Property Let MouseTrack(ByVal Value As Boolean)
PropMouseTrack = Value
UserControl.PropertyChanged "MouseTrack"
End Property
Public Property Get RightToLeft() As Boolean
RightToLeft = PropRightToLeft
End Property
Public Property Let RightToLeft(ByVal Value As Boolean)
PropRightToLeft = Value
UserControl.RightToLeft = PropRightToLeft
Call ComCtlsCheckRightToLeft(PropRightToLeft, UserControl.RightToLeft, PropRightToLeftMode)
Dim dwMask As Long
If PropRightToLeft = True Then dwMask = WS_EX_RTLREADING Or WS_EX_RIGHT Or WS_EX_LEFTSCROLLBAR
If ListBoxHandle <> 0 Then Call ComCtlsSetRightToLeft(ListBoxHandle, dwMask)
UserControl.PropertyChanged "RightToLeft"
End Property
Public Property Get RightToLeftMode() As CCRightToLeftModeConstants
RightToLeftMode = PropRightToLeftMode
End Property
Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants)
Select Case Value
Case CCRightToLeftModeNoControl, CCRightToLeftModeVBAME, CCRightToLeftModeSystemLocale, CCRightToLeftModeUserLocale, CCRightToLeftModeOSLanguage
PropRightToLeftMode = Value
Case Else
ERR.Raise 380
End Select
Me.RightToLeft = PropRightToLeft
UserControl.PropertyChanged "RightToLeftMode"
End Property
Public Property Get Redraw() As Boolean
Redraw = PropRedraw
End Property
Public Property Let Redraw(ByVal Value As Boolean)
PropRedraw = Value
If ListBoxHandle <> 0 And ListBoxDesignMode = False Then
SendMessage ListBoxHandle, WM_SETREDRAW, IIf(PropRedraw = True, 1, 0), ByVal 0&
If PropRedraw = True Then Me.Refresh
End If
UserControl.PropertyChanged "Redraw"
End Property
Public Property Get BorderStyle() As CCBorderStyleConstants
BorderStyle = PropBorderStyle
End Property
Public Property Let BorderStyle(ByVal Value As CCBorderStyleConstants)
Select Case Value
Case CCBorderStyleNone, CCBorderStyleSingle, CCBorderStyleThin, CCBorderStyleSunken, CCBorderStyleRaised
PropBorderStyle = Value
Case Else
ERR.Raise 380
End Select
If ListBoxHandle <> 0 Then
Call ComCtlsChangeBorderStyle(ListBoxHandle, PropBorderStyle)
Call UserControl_Resize
End If
UserControl.PropertyChanged "BorderStyle"
End Property
Public Property Get MultiColumn() As Boolean
MultiColumn = PropMultiColumn
End Property
Public Property Let MultiColumn(ByVal Value As Boolean)
If PropDrawMode = LstDrawModeOwnerDrawVariable And Value = True Then
If ListBoxDesignMode = True Then
MsgBox "MultiColumn must be False when DrawMode is 2 - OwnerDrawVariable", vbCritical + vbOKOnly
Exit Property
Else
ERR.Raise Number:=383, Description:="MultiColumn must be False when DrawMode is 2 - OwnerDrawVariable"
End If
End If
PropMultiColumn = Value
If ListBoxHandle <> 0 Then Call ReCreateListBox
UserControl.PropertyChanged "MultiColumn"
End Property
Public Property Get Sorted() As Boolean
Sorted = PropSorted
End Property
Public Property Let Sorted(ByVal Value As Boolean)
PropSorted = Value
If ListBoxHandle <> 0 Then Call ReCreateListBox
UserControl.PropertyChanged "Sorted"
End Property
Public Property Get IntegralHeight() As Boolean
IntegralHeight = PropIntegralHeight
End Property
Public Property Let IntegralHeight(ByVal Value As Boolean)
If ListBoxDesignMode = False Then
ERR.Raise Number:=382, Description:="IntegralHeight property is read-only at run time"
Else
PropIntegralHeight = Value
If ListBoxHandle <> 0 Then Call ReCreateListBox
End If
UserControl.PropertyChanged "IntegralHeight"
End Property
Public Property Get AllowSelection() As Boolean
AllowSelection = PropAllowSelection
End Property
Public Property Let AllowSelection(ByVal Value As Boolean)
PropAllowSelection = Value
If ListBoxHandle <> 0 Then Call ReCreateListBox
UserControl.PropertyChanged "AllowSelection"
End Property
Public Property Get MultiSelect() As VBRUN.MultiSelectConstants
MultiSelect = PropMultiSelect
End Property
Public Property Let MultiSelect(ByVal Value As VBRUN.MultiSelectConstants)
Select Case Value
Case vbMultiSelectNone, vbMultiSelectSimple, vbMultiSelectExtended
If PropStyle <> LstStyleStandard And Value <> vbMultiSelectNone Then
If ListBoxDesignMode = True Then
MsgBox "MultiSelect must be 0 - None when Style is not 0 - Standard", vbCritical + vbOKOnly
Exit Property
Else
ERR.Raise Number:=383, Description:="MultiSelect must be 0 - None when Style is not 0 - Standard"
End If
End If
PropMultiSelect = Value
Case Else
ERR.Raise 380
End Select
If ListBoxHandle <> 0 Then Call ReCreateListBox
UserControl.PropertyChanged "MultiSelect"
End Property
Public Property Get HorizontalExtent() As Single
If ListBoxHandle <> 0 And PropMultiColumn = False Then
HorizontalExtent = UserControl.ScaleX(SendMessage(ListBoxHandle, LB_GETHORIZONTALEXTENT, 0, ByVal 0&), vbPixels, vbContainerSize)
Else
HorizontalExtent = UserControl.ScaleX(PropHorizontalExtent, vbPixels, vbContainerSize)
End If
End Property
Public Property Let HorizontalExtent(ByVal Value As Single)
If Value < 0 Then
If ListBoxDesignMode = True Then
MsgBox "Invalid property value", vbCritical + vbOKOnly
Exit Property
Else
ERR.Raise 380
End If
End If
PropHorizontalExtent = CLng(UserControl.ScaleX(Value, vbContainerSize, vbPixels))
If ListBoxHandle <> 0 And PropMultiColumn = False Then SendMessage ListBoxHandle, LB_SETHORIZONTALEXTENT, PropHorizontalExtent, ByVal 0&
UserControl.PropertyChanged "HorizontalExtent"
End Property
Public Property Get UseTabStops() As Boolean
UseTabStops = PropUseTabStops
End Property
Public Property Let UseTabStops(ByVal Value As Boolean)
PropUseTabStops = Value
If ListBoxHandle <> 0 Then Call ReCreateListBox
UserControl.PropertyChanged "UseTabStops"
End Property
Public Property Get Style() As LstStyleConstants
Style = PropStyle
End Property
Public Property Let Style(ByVal Value As LstStyleConstants)
If ListBoxDesignMode = False Then
ERR.Raise Number:=382, Description:="Style property is read-only at run time"
Else
Select Case Value
Case LstStyleStandard, LstStyleCheckbox, LstStyleOption
If PropDrawMode <> LstDrawModeNormal And Value <> LstStyleStandard Then
MsgBox "Style must be 0 - Standard when DrawMode is not 0 - Normal", vbCritical + vbOKOnly
Exit Property
End If
PropStyle = Value
If PropStyle <> LstStyleStandard Then PropMultiSelect = vbMultiSelectNone
Case Else
ERR.Raise 380
End Select
If ListBoxHandle <> 0 Then Call ReCreateListBox
End If
UserControl.PropertyChanged "Style"
End Property
Public Property Get DisableNoScroll() As Boolean
DisableNoScroll = PropDisableNoScroll
End Property
Public Property Let DisableNoScroll(ByVal Value As Boolean)
PropDisableNoScroll = Value
If ListBoxHandle <> 0 Then Call ReCreateListBox
UserControl.PropertyChanged "DisableNoScroll"
End Property
Public Property Get DrawMode() As LstDrawModeConstants
DrawMode = PropDrawMode
End Property
Public Property Let DrawMode(ByVal Value As LstDrawModeConstants)
Select Case Value
Case LstDrawModeNormal, LstDrawModeOwnerDrawFixed, LstDrawModeOwnerDrawVariable
If ListBoxDesignMode = False Then
ERR.Raise Number:=382, Description:="DrawMode property is read-only at run time"
Else
PropDrawMode = Value
End If
Case Else
ERR.Raise 380
End Select
If ListBoxHandle <> 0 Then Call ReCreateListBox
UserControl.PropertyChanged "DrawMode"
End Property
Public Property Get InsertMarkColor() As OLE_COLOR
InsertMarkColor = PropInsertMarkColor
End Property
Public Property Let InsertMarkColor(ByVal Value As OLE_COLOR)
PropInsertMarkColor = Value
If ListBoxInsertMark > -1 Then Call InvalidateInsertMark
UserControl.PropertyChanged "InsertMarkColor"
End Property
Public Property Get ScrollTrack() As Boolean
ScrollTrack = PropScrollTrack
End Property
Public Property Let ScrollTrack(ByVal Value As Boolean)
PropScrollTrack = Value
UserControl.PropertyChanged "ScrollTrack"
End Property
Public Sub AddItem(ByVal Item As String, Optional ByVal Index As Variant)
If ListBoxHandle <> 0 Then
Dim RetVal As Long
If IsMissing(Index) = True Then
RetVal = SendMessage(ListBoxHandle, LB_ADDSTRING, 0, ByVal StrPtr(Item))
Else
Dim IndexLong As Long
Select Case VarType(Index)
Case vbLong, vbInteger, vbByte
If Index >= 0 Then
IndexLong = Index
Else
ERR.Raise 5
End If
Case vbDouble, vbSingle
If CLng(Index) >= 0 Then
IndexLong = CLng(Index)
Else
ERR.Raise 5
End If
Case vbString
IndexLong = CLng(Index)
If IndexLong < 0 Then ERR.Raise 5
Case Else
ERR.Raise 13
End Select
RetVal = SendMessage(ListBoxHandle, LB_INSERTSTRING, IndexLong, ByVal StrPtr(Item))
End If
If Not RetVal = LB_ERR Then
ListBoxNewIndex = RetVal
If PropStyle <> LstStyleStandard Then
ListBoxItemCheckedCount = ListBoxItemCheckedCount + 1
If PropStyle = LstStyleCheckbox Then
ReDim Preserve ListBoxItemChecked(0 To ListBoxItemCheckedCount) As Byte
If ListBoxNewIndex < (ListBoxItemCheckedCount - 1) Then CopyMemory ByVal VarPtr(ListBoxItemChecked(ListBoxNewIndex + 2)), ByVal VarPtr(ListBoxItemChecked(ListBoxNewIndex + 1)), (ListBoxItemCheckedCount - ListBoxNewIndex - 1)
ListBoxItemChecked(ListBoxNewIndex + 1) = vbUnchecked
ElseIf PropStyle = LstStyleOption Then
If ListBoxNewIndex <= ListBoxOptionIndex Then ListBoxOptionIndex = ListBoxOptionIndex + 1
End If
End If
Else
ERR.Raise 5
End If
End If
End Sub
Public Sub RemoveItem(ByVal Index As Long)
If ListBoxHandle <> 0 Then
If Index >= 0 Then
If Not SendMessage(ListBoxHandle, LB_DELETESTRING, Index, ByVal 0&) = LB_ERR Then
ListBoxNewIndex = -1
If ListBoxInsertMark > -1 Then
If ListBoxInsertMark > (SendMessage(ListBoxHandle, LB_GETCOUNT, 0, ByVal 0&) - 1) Then
ListBoxInsertMark = -1
ListBoxInsertMarkAfter = False
End If
End If
If PropStyle <> LstStyleStandard Then
ListBoxItemCheckedCount = ListBoxItemCheckedCount - 1
If PropStyle = LstStyleCheckbox Then
If ListBoxItemCheckedCount > 0 Then
If Index < ListBoxItemCheckedCount Then CopyMemory ByVal VarPtr(ListBoxItemChecked(Index + 1)), ByVal VarPtr(ListBoxItemChecked(Index + 2)), (ListBoxItemCheckedCount - Index)
ReDim Preserve ListBoxItemChecked(0 To ListBoxItemCheckedCount) As Byte
Else
ReDim ListBoxItemChecked(0) As Byte
End If
ElseIf PropStyle = LstStyleOption Then
If ListBoxOptionIndex > -1 Then
If ListBoxItemCheckedCount > 0 Then
If ListBoxOptionIndex > (SendMessage(ListBoxHandle, LB_GETCOUNT, 0, ByVal 0&) - 1) Then
ListBoxOptionIndex = -1
ElseIf Index = ListBoxOptionIndex Then
ListBoxOptionIndex = -1
ElseIf Index < ListBoxOptionIndex Then
ListBoxOptionIndex = ListBoxOptionIndex - 1
End If
Else
ListBoxOptionIndex = -1
End If
End If
End If
End If
Else
ERR.Raise 5
End If
Else
ERR.Raise 5
End If
End If
End Sub
Public Sub Clear()
If ListBoxHandle <> 0 Then
SendMessage ListBoxHandle, LB_RESETCONTENT, 0, ByVal 0&
ListBoxNewIndex = -1
If PropStyle <> LstStyleStandard Then
ListBoxItemCheckedCount = 0
ReDim ListBoxItemChecked(0) As Byte
ListBoxOptionIndex = -1
End If
End If
End Sub
Public Property Get ListCount() As Long
If ListBoxHandle <> 0 Then ListCount = SendMessage(ListBoxHandle, LB_GETCOUNT, 0, ByVal 0&)
End Property
Public Property Get List(ByVal Index As Long) As String
If ListBoxHandle <> 0 Then
Dim Length As Long
Length = SendMessage(ListBoxHandle, LB_GETTEXTLEN, Index, ByVal 0&)
If Not Length = LB_ERR Then
List = String(Length, vbNullChar)
SendMessage ListBoxHandle, LB_GETTEXT, Index, ByVal StrPtr(List)
Else
ERR.Raise 5
End If
End If
End Property
Public Property Let List(ByVal Index As Long, ByVal Value As String)
If ListBoxHandle <> 0 Then
If Index > -1 Then
Dim ListIndex As Long, SelVal As Long, ItemData As Long
ListIndex = Me.ListIndex
If PropMultiSelect <> vbMultiSelectNone Then SelVal = SendMessage(ListBoxHandle, LB_GETSEL, Index, ByVal 0&)
ItemData = SendMessage(ListBoxHandle, LB_GETITEMDATA, Index, ByVal 0&)
If Not SendMessage(ListBoxHandle, LB_DELETESTRING, Index, ByVal 0&) = LB_ERR Then
SendMessage ListBoxHandle, LB_INSERTSTRING, Index, ByVal StrPtr(Value)
Me.ListIndex = ListIndex
If PropMultiSelect <> vbMultiSelectNone And Not SelVal = LB_ERR Then SendMessage ListBoxHandle, LB_SETSEL, SelVal, ByVal Index
SendMessage ListBoxHandle, LB_SETITEMDATA, Index, ByVal ItemData
Else
ERR.Raise 5
End If
Else
ERR.Raise 5
End If
End If
End Property
Public Property Get ListIndex() As Long
If ListBoxHandle <> 0 Then
If PropMultiSelect = vbMultiSelectNone Then
ListIndex = SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&)
Else
ListIndex = SendMessage(ListBoxHandle, LB_GETCARETINDEX, 0, ByVal 0&)
End If
End If
End Property
Public Property Let ListIndex(ByVal Value As Long)
If ListBoxHandle <> 0 Then
Dim Changed As Boolean
If PropMultiSelect = vbMultiSelectNone Then
Changed = CBool(SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&) <> Value)
If Not Value = -1 Then
If SendMessage(ListBoxHandle, LB_SETCURSEL, Value, ByVal 0&) = LB_ERR Then ERR.Raise 380
Else
SendMessage ListBoxHandle, LB_SETCURSEL, -1, ByVal 0&
End If
Else
Changed = CBool(SendMessage(ListBoxHandle, LB_GETCARETINDEX, 0, ByVal 0&) <> Value)
If SendMessage(ListBoxHandle, LB_SETCARETINDEX, Value, ByVal 0&) = LB_ERR Then ERR.Raise 380
End If
If Changed = True Then RaiseEvent Click
End If
End Property
Public Property Get ItemData(ByVal Index As Long) As Long
If ListBoxHandle <> 0 Then
If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Index, ByVal 0&) = LB_ERR Then
ItemData = SendMessage(ListBoxHandle, LB_GETITEMDATA, Index, ByVal 0&)
Else
ERR.Raise 381
End If
End If
End Property
Public Property Let ItemData(ByVal Index As Long, ByVal Value As Long)
If ListBoxHandle <> 0 Then If SendMessage(ListBoxHandle, LB_SETITEMDATA, Index, ByVal Value) = LB_ERR Then ERR.Raise 381
End Property
Public Property Get ItemChecked(ByVal Index As Long) As Boolean
If ListBoxHandle <> 0 Then
If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Index, ByVal 0&) = LB_ERR Then
If Index <= (ListBoxItemCheckedCount - 1) Then
If PropStyle = LstStyleCheckbox Then
ItemChecked = CBool(ListBoxItemChecked(Index + 1) = vbChecked)
ElseIf PropStyle = LstStyleOption Then
ItemChecked = CBool(ListBoxOptionIndex = Index)
End If
End If
Else
ERR.Raise 381
End If
End If
End Property
Public Property Let ItemChecked(ByVal Index As Long, ByVal Value As Boolean)
If ListBoxHandle <> 0 Then
If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Index, ByVal 0&) = LB_ERR Then
If Index <= (ListBoxItemCheckedCount - 1) Then
Dim Changed As Boolean
If PropStyle = LstStyleCheckbox Then
Changed = CBool(ListBoxItemChecked(Index + 1) <> IIf(Value = True, vbChecked, vbUnchecked))
ElseIf PropStyle = LstStyleOption Then
If ListBoxOptionIndex <> Index Then
Changed = Value
ElseIf Value = False Then
Changed = True
End If
End If
If Changed = True Then
Dim Cancel As Boolean
RaiseEvent ItemBeforeCheck(Index, Cancel)
If Cancel = False Then
Dim RC As RECT
If PropStyle = LstStyleCheckbox Then
ListBoxItemChecked(Index + 1) = IIf(Value = True, vbChecked, vbUnchecked)
ElseIf PropStyle = LstStyleOption Then
If ListBoxOptionIndex > -1 Then
SendMessage ListBoxHandle, LB_GETITEMRECT, ListBoxOptionIndex, ByVal VarPtr(RC)
InvalidateRect ListBoxHandle, RC, 0
End If
If ListBoxOptionIndex <> Index Then
ListBoxOptionIndex = Index
ElseIf Value = False Then
ListBoxOptionIndex = -1
End If
End If
SendMessage ListBoxHandle, LB_GETITEMRECT, Index, ByVal VarPtr(RC)
InvalidateRect ListBoxHandle, RC, 0
RaiseEvent ItemCheck(Index)
End If
End If
End If
Else
ERR.Raise 381
End If
End If
End Property
Private Sub CreateListBox()
If ListBoxHandle <> 0 Then Exit Sub
Dim dwStyle As Long, dwExStyle As Long
dwStyle = WS_CHILD Or WS_VISIBLE Or LBS_NOTIFY Or WS_HSCROLL
If PropRedraw = False Then dwStyle = dwStyle Or LBS_NOREDRAW
Call ComCtlsInitBorderStyle(dwStyle, dwExStyle, PropBorderStyle)
If PropDrawMode = LstDrawModeOwnerDrawVariable Then
' The LBS_MULTICOLUMN and LBS_OWNERDRAWVARIABLE styles cannot be combined.
PropMultiColumn = False
' In an variable owner-drawn list box it makes no sense to have an integral height.
' Otherwise it would come to unpredictable adjustments.
PropIntegralHeight = False
End If
If PropMultiColumn = False Then
dwStyle = dwStyle Or WS_VSCROLL
If PropRightToLeft = True Then dwExStyle = dwExStyle Or WS_EX_RTLREADING Or WS_EX_RIGHT Or WS_EX_LEFTSCROLLBAR
Else
dwStyle = dwStyle Or LBS_MULTICOLUMN
End If
If PropSorted = True Then dwStyle = dwStyle Or LBS_SORT
If PropIntegralHeight = False Then dwStyle = dwStyle Or LBS_NOINTEGRALHEIGHT
If PropAllowSelection = False Then dwStyle = dwStyle Or LBS_NOSEL
Select Case PropMultiSelect
Case vbMultiSelectSimple
dwStyle = dwStyle Or LBS_MULTIPLESEL
Case vbMultiSelectExtended
dwStyle = dwStyle Or LBS_EXTENDEDSEL
End Select
If PropUseTabStops = True Then dwStyle = dwStyle Or LBS_USETABSTOPS
If PropDrawMode <> LstDrawModeNormal Then PropStyle = vbListBoxStandard
If PropStyle <> LstStyleStandard Then dwStyle = dwStyle Or LBS_OWNERDRAWFIXED Or LBS_HASSTRINGS
If PropDisableNoScroll = True Then dwStyle = dwStyle Or LBS_DISABLENOSCROLL
Select Case PropDrawMode
Case LstDrawModeOwnerDrawFixed
dwStyle = dwStyle Or LBS_OWNERDRAWFIXED Or LBS_HASSTRINGS
Case LstDrawModeOwnerDrawVariable
dwStyle = dwStyle Or LBS_OWNERDRAWVARIABLE Or LBS_HASSTRINGS
End Select
ListBoxHandle = CreateWindowEx(dwExStyle, StrPtr("ListBox"), 0, dwStyle, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight, UserControl.hwnd, 0, App.hInstance, ByVal 0&)
If ListBoxHandle <> 0 Then
Call ComCtlsShowAllUIStates(ListBoxHandle)
If PropMultiColumn = True And PropRightToLeft = True Then
' In a multi-column list box it is necessary to set the right-to-left alignment afterwards.
' Else the top index gets negative and everything will be unpredictable and unstable. (Bug?)
Call ComCtlsSetRightToLeft(ListBoxHandle, WS_EX_RTLREADING Or WS_EX_RIGHT Or WS_EX_LEFTSCROLLBAR)
End If
If PropMultiColumn = False And PropHorizontalExtent > 0 Then SendMessage ListBoxHandle, LB_SETHORIZONTALEXTENT, PropHorizontalExtent, ByVal 0&
ListBoxNewIndex = -1
ListBoxTopIndex = 0
ListBoxInsertMark = -1
ListBoxInsertMarkAfter = False
ListBoxOptionIndex = -1
End If
Set Me.Font = PropFont
Me.VisualStyles = PropVisualStyles
Me.Enabled = UserControl.Enabled
If ListBoxDesignMode = False Then
If ListBoxHandle <> 0 Then Call ComCtlsSetSubclass(ListBoxHandle, Me, 1)
Call ComCtlsSetSubclass(UserControl.hwnd, Me, 2)
Else
If ListBoxHandle <> 0 Then
Dim Buffer As String
Buffer = Ambient.DisplayName
SendMessage ListBoxHandle, LB_ADDSTRING, 0, ByVal StrPtr(Buffer)
SendMessage ListBoxHandle, LB_SETCURSEL, -1, ByVal 0&
End If
If PropStyle <> LstStyleStandard Then
Call ComCtlsSetSubclass(UserControl.hwnd, Me, 3)
Me.Refresh
End If
End If
End Sub
Private Sub ReCreateListBox()
If ListBoxDesignMode = False Then
Dim Locked As Boolean
With Me
Locked = CBool(LockWindowUpdate(UserControl.hwnd) <> 0)
Dim ListArr() As String, ItemDataArr() As Long, ItemSelArr() As Long
Dim ItemHeight As Long, ListIndex As Long, TopIndex As Long, NewIndex As Long, InsertMark As Long, InsertMarkAfter As Boolean
Dim Count As Long, i As Long
If ListBoxHandle <> 0 Then
ItemHeight = SendMessage(ListBoxHandle, LB_GETITEMHEIGHT, 0, ByVal 0&)
Count = SendMessage(ListBoxHandle, LB_GETCOUNT, 0, ByVal 0&)
If Count > 0 Then
ReDim ListArr(0 To (Count - 1)) As String
ReDim ItemDataArr(0 To (Count - 1)) As Long
ReDim ItemSelArr(0 To (Count - 1)) As Long
For i = 0 To (Count - 1)
ListArr(i) = .List(i)
ItemDataArr(i) = SendMessage(ListBoxHandle, LB_GETITEMDATA, i, ByVal 0&)
If PropMultiSelect <> vbMultiSelectNone Then ItemSelArr(i) = SendMessage(ListBoxHandle, LB_GETSEL, i, ByVal 0&)
Next i
End If
ListIndex = .ListIndex
TopIndex = .TopIndex
End If
NewIndex = ListBoxNewIndex
InsertMark = ListBoxInsertMark
InsertMarkAfter = ListBoxInsertMarkAfter
Call DestroyListBox
Call CreateListBox
Call UserControl_Resize
If ListBoxHandle <> 0 Then
SendMessage ListBoxHandle, LB_SETITEMHEIGHT, 0, ByVal ItemHeight
If Count > 0 Then
SendMessage ListBoxHandle, WM_SETREDRAW, 0, ByVal 0&
For i = 0 To (Count - 1)
SendMessage ListBoxHandle, LB_INSERTSTRING, i, ByVal StrPtr(ListArr(i))
SendMessage ListBoxHandle, LB_SETITEMDATA, i, ByVal ItemDataArr(i)
If PropMultiSelect <> vbMultiSelectNone Then SendMessage ListBoxHandle, LB_SETSEL, ItemSelArr(i), ByVal i
Next i
SendMessage ListBoxHandle, WM_SETREDRAW, 1, ByVal 0&
End If
.ListIndex = ListIndex
.TopIndex = TopIndex
End If
ListBoxNewIndex = NewIndex
ListBoxInsertMark = InsertMark
ListBoxInsertMarkAfter = InsertMarkAfter
If Locked = True Then LockWindowUpdate 0
.Refresh
If PropRedraw = False Then .Redraw = PropRedraw
End With
Else
Call DestroyListBox
Call ComCtlsRemoveSubclass(UserControl.hwnd)
Call CreateListBox
Call UserControl_Resize
End If
End Sub
Private Sub DestroyListBox()
If ListBoxHandle = 0 Then Exit Sub
Call ComCtlsRemoveSubclass(ListBoxHandle)
Call ComCtlsRemoveSubclass(UserControl.hwnd)
ShowWindow ListBoxHandle, SW_HIDE
SetParent ListBoxHandle, 0
DestroyWindow ListBoxHandle
ListBoxHandle = 0
If ListBoxFontHandle <> 0 Then
DeleteObject ListBoxFontHandle
ListBoxFontHandle = 0
End If
End Sub
Public Sub Refresh()
UserControl.Refresh
If PropRedraw = True Or ListBoxDesignMode = True Then RedrawWindow UserControl.hwnd, 0, 0, RDW_UPDATENOW Or RDW_INVALIDATE Or RDW_ERASE Or RDW_ALLCHILDREN
End Sub
Public Property Get Text() As String
If ListBoxHandle <> 0 Then
Dim Index As Long
Index = Me.ListIndex
If Index > -1 Then Text = Me.List(Index)
End If
End Property
Public Property Let Text(ByVal Value As String)
If ListBoxHandle <> 0 Then Me.ListIndex = SendMessage(ListBoxHandle, LB_FINDSTRINGEXACT, -1, ByVal StrPtr(Value))
End Property
Public Property Get SelCount() As Long
If ListBoxHandle <> 0 Then
Dim RetVal As Long
RetVal = SendMessage(ListBoxHandle, LB_GETSELCOUNT, 0, ByVal 0&)
If Not RetVal = LB_ERR Then
SelCount = RetVal
Else
RetVal = SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&)
If Not RetVal = LB_ERR Then
RetVal = SendMessage(ListBoxHandle, LB_GETSEL, RetVal, ByVal 0&)
If RetVal > 0 Then SelCount = 1
End If
End If
End If
End Property
Public Property Get Selected(ByVal Index As Long) As Boolean
If ListBoxHandle <> 0 Then
If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Index, ByVal 0&) = LB_ERR Then
Selected = CBool(SendMessage(ListBoxHandle, LB_GETSEL, Index, ByVal 0&) > 0)
Else
ERR.Raise 381
End If
End If
End Property
Public Property Let Selected(ByVal Index As Long, ByVal Value As Boolean)
If ListBoxHandle <> 0 Then
If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Index, ByVal 0&) = LB_ERR Then
Dim Changed As Boolean, RetVal As Long
If PropMultiSelect <> vbMultiSelectNone Then
RetVal = IIf(SendMessage(ListBoxHandle, LB_GETSEL, Index, ByVal 0&) > 0, 1, 0)
SendMessage ListBoxHandle, LB_SETSEL, IIf(Value = True, 1, 0), ByVal Index
Changed = CBool(IIf(SendMessage(ListBoxHandle, LB_GETSEL, Index, ByVal 0&) > 0, 1, 0) <> RetVal)
Else
RetVal = SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&)
If Value = False Then
If SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&) = Index Then
If SendMessage(ListBoxHandle, LB_GETSEL, Index, ByVal 0&) > 0 Then SendMessage ListBoxHandle, LB_SETCURSEL, -1, ByVal 0&
End If
Else
SendMessage ListBoxHandle, LB_SETCURSEL, Index, ByVal 0&
End If
Changed = CBool(SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&) <> RetVal)
End If
If Changed = True Then RaiseEvent Click
Else
ERR.Raise 381
End If
End If
End Property
Public Sub SetSelRange(ByVal StartIndex As Long, ByVal EndIndex As Long)
If ListBoxHandle <> 0 Then
If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, StartIndex, ByVal 0&) = LB_ERR And Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, EndIndex, ByVal 0&) = LB_ERR Then
Dim RetVal As Long
RetVal = SendMessage(ListBoxHandle, LB_GETSELCOUNT, 0, ByVal 0&)
If Not RetVal = LB_ERR Then
Dim Changed As Boolean
SendMessage ListBoxHandle, LB_SELITEMRANGEEX, StartIndex, ByVal EndIndex
Changed = CBool(SendMessage(ListBoxHandle, LB_GETSELCOUNT, 0, ByVal 0&) <> RetVal)
If Changed = True Then RaiseEvent Click
Else
Me.ListIndex = StartIndex
End If
Else
ERR.Raise 381
End If
End If
End Sub
Public Property Get ItemHeight(Optional ByVal Index As Long) As Single
If ListBoxHandle <> 0 Then
Dim RetVal As Long
If PropDrawMode <> LstDrawModeOwnerDrawVariable Then
If Index = 0 Then
RetVal = SendMessage(ListBoxHandle, LB_GETITEMHEIGHT, 0, ByVal 0&)
Else
RetVal = LB_ERR
End If
Else
RetVal = SendMessage(ListBoxHandle, LB_GETITEMHEIGHT, Index, ByVal 0&)
End If
If Not RetVal = LB_ERR Then
ItemHeight = UserControl.ScaleY(RetVal, vbPixels, vbContainerSize)
Else
ERR.Raise 5
End If
End If
End Property
Public Property Let ItemHeight(Optional ByVal Index As Long, ByVal Value As Single)
If Value < 0 Then ERR.Raise 380
If ListBoxHandle <> 0 Then
Dim RetVal As Long
If PropDrawMode <> LstDrawModeOwnerDrawVariable Then
If Index = 0 Then
RetVal = SendMessage(ListBoxHandle, LB_SETITEMHEIGHT, 0, ByVal CLng(UserControl.ScaleY(Value, vbContainerSize, vbPixels)))
Else
RetVal = LB_ERR
End If
Else
RetVal = SendMessage(ListBoxHandle, LB_SETITEMHEIGHT, Index, ByVal CLng(UserControl.ScaleY(Value, vbContainerSize, vbPixels)))
End If
If Not RetVal = LB_ERR Then
If PropIntegralHeight = True Then
With UserControl
MoveWindow ListBoxHandle, 0, 0, .ScaleWidth, .ScaleHeight + 10, 0
MoveWindow ListBoxHandle, 0, 0, .ScaleWidth, .ScaleHeight, 0
End With
Call UserControl_Resize
End If
Me.Refresh
Else
ERR.Raise 5
End If
End If
End Property
Public Property Get NewIndex() As Long
NewIndex = ListBoxNewIndex
End Property
Public Property Get TopIndex() As Long
If ListBoxHandle <> 0 Then TopIndex = SendMessage(ListBoxHandle, LB_GETTOPINDEX, 0, ByVal 0&)
End Property
Public Property Let TopIndex(ByVal Value As Long)
If ListBoxHandle <> 0 Then
If Value >= 0 Then
If SendMessage(ListBoxHandle, LB_SETTOPINDEX, Value, ByVal 0&) = LB_ERR Then ERR.Raise 380
Else
ERR.Raise 380
End If
End If
End Property
Public Property Get AnchorIndex() As Long
If ListBoxHandle <> 0 Then AnchorIndex = SendMessage(ListBoxHandle, LB_GETANCHORINDEX, 0, ByVal 0&)
End Property
Public Property Let AnchorIndex(ByVal Value As Long)
If ListBoxHandle <> 0 Then
If Value < -1 Then
ERR.Raise 380
Else
If SendMessage(ListBoxHandle, LB_SETANCHORINDEX, Value, ByVal 0&) = LB_ERR Then ERR.Raise 380
End If
End If
End Property
Public Sub SetColumnWidth(ByVal Value As Single)
If Value < 0 Then ERR.Raise 380
If ListBoxHandle <> 0 Then
Dim LngValue As Long
LngValue = CLng(UserControl.ScaleX(Value, vbContainerSize, vbPixels))
If LngValue > 0 Then
SendMessage ListBoxHandle, LB_SETCOLUMNWIDTH, LngValue, ByVal 0&
Else
ERR.Raise 380
End If
End If
End Sub
Public Function ItemsPerColumn() As Long
If ListBoxHandle <> 0 Then ItemsPerColumn = SendMessage(ListBoxHandle, LB_GETLISTBOXINFO, 0, ByVal 0&)
End Function
Public Function SelectedIndices() As Collection
If ListBoxHandle <> 0 Then
Set SelectedIndices = New Collection
Dim Count As Long
Count = SendMessage(ListBoxHandle, LB_GETCOUNT, 0, ByVal 0&)
If Count > 0 Then
Dim LngArr() As Long, RetVal As Long
ReDim LngArr(1 To Count) As Long
RetVal = SendMessage(ListBoxHandle, LB_GETSELITEMS, Count, ByVal VarPtr(LngArr(1)))
If Not RetVal = LB_ERR Then
Dim i As Long
For i = 1 To RetVal
SelectedIndices.Add LngArr(i)
Next i
Else
RetVal = SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&)
If Not RetVal = LB_ERR Then
If SendMessage(ListBoxHandle, LB_GETSEL, RetVal, ByVal 0&) > 0 Then
SelectedIndices.Add RetVal
End If
End If
End If
End If
End If
End Function
Public Function CheckedIndices() As Collection
If ListBoxHandle <> 0 Then
Set CheckedIndices = New Collection
Dim Count As Long
Count = SendMessage(ListBoxHandle, LB_GETCOUNT, 0, ByVal 0&)
If Count > 0 Then
If PropStyle = LstStyleCheckbox Then
Dim i As Long
For i = 1 To UBound(ListBoxItemChecked())
If ListBoxItemChecked(i) = vbChecked Then CheckedIndices.Add (i - 1)
Next i
ElseIf PropStyle = LstStyleOption Then
If ListBoxOptionIndex > -1 Then CheckedIndices.Add ListBoxOptionIndex
End If
End If
End If
End Function
Public Function HitTest(ByVal X As Single, ByVal Y As Single) As Long
If ListBoxHandle <> 0 Then
Dim p As POINTAPI
p.X = UserControl.ScaleX(X, vbContainerPosition, vbPixels)
p.Y = UserControl.ScaleY(Y, vbContainerPosition, vbPixels)
ClientToScreen ListBoxHandle, p
HitTest = LBItemFromPt(ListBoxHandle, p.X, p.Y, 0)
End If
End Function
Public Function HitTestInsertMark(ByVal X As Single, ByVal Y As Single, Optional ByRef After As Boolean) As Long
If ListBoxHandle <> 0 Then
Dim p As POINTAPI, Index As Long
p.X = UserControl.ScaleX(X, vbContainerPosition, vbPixels)
p.Y = UserControl.ScaleY(Y, vbContainerPosition, vbPixels)
ClientToScreen ListBoxHandle, p
Index = LBItemFromPt(ListBoxHandle, p.X, p.Y, 0)
If Index > -1 Then
Dim RC As RECT
SendMessage ListBoxHandle, LB_GETITEMRECT, Index, ByVal VarPtr(RC)
After = CBool(CLng(UserControl.ScaleY(Y, vbContainerPosition, vbPixels)) > (RC.Top + ((RC.Bottom - RC.Top) / 2)))
End If
HitTestInsertMark = Index
End If
End Function
Public Function FindItem(ByVal Text As String, Optional ByVal Index As Long = -1, Optional ByVal Partial As Boolean) As Long
If ListBoxHandle <> 0 Then
If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Index, ByVal 0&) = LB_ERR Or Index = -1 Then
If Partial = True Then
FindItem = SendMessage(ListBoxHandle, LB_FINDSTRING, Index, ByVal StrPtr(Text))
Else
FindItem = SendMessage(ListBoxHandle, LB_FINDSTRINGEXACT, Index, ByVal StrPtr(Text))
End If
Else
ERR.Raise 381
End If
End If
End Function
Public Property Get InsertMark(Optional ByRef After As Boolean) As Long
InsertMark = ListBoxInsertMark
After = ListBoxInsertMarkAfter
End Property
Public Property Let InsertMark(Optional ByRef After As Boolean, ByVal Value As Long)
If ListBoxInsertMark = Value And ListBoxInsertMarkAfter = After Then Exit Property
If ListBoxHandle <> 0 Then
If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Value, ByVal 0&) = LB_ERR Or Value = -1 Then
If ListBoxInsertMark > -1 Then Call InvalidateInsertMark
ListBoxInsertMark = Value
ListBoxInsertMarkAfter = After
If ListBoxInsertMark > -1 Then Call InvalidateInsertMark
Else
ERR.Raise 381
End If
End If
End Property
Public Property Get OptionIndex() As Long
OptionIndex = ListBoxOptionIndex
End Property
Public Property Let OptionIndex(ByVal Value As Long)
If ListBoxHandle <> 0 Then
If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Value, ByVal 0&) = LB_ERR Or Value = -1 Then
If PropStyle = LstStyleOption Then
If Value > -1 Then
Me.ItemChecked(Value) = True
Else
If ListBoxOptionIndex > -1 Then Me.ItemChecked(ListBoxOptionIndex) = False
End If
End If
Else
ERR.Raise 381
End If
End If
End Property
Public Property Get OLEDraggedItem() As Long
OLEDraggedItem = ListBoxDragIndex - 1
End Property
Public Function GetIdealHorizontalExtent() As Single
If ListBoxHandle <> 0 Then
Dim Count As Long
Count = SendMessage(ListBoxHandle, LB_GETCOUNT, 0, ByVal 0&)
If Count > 0 Then
Dim RC(0 To 1) As RECT, cx As Long, ScrollWidth As Long, hDC As Long, i As Long, Length As Long, Text As String, Size As SIZEAPI
GetWindowRect ListBoxHandle, RC(0)
GetClientRect ListBoxHandle, RC(1)
If (GetWindowLong(ListBoxHandle, GWL_STYLE) And WS_VSCROLL) = WS_VSCROLL Then
Const SM_CXVSCROLL As Long = 2
ScrollWidth = GetSystemMetrics(SM_CXVSCROLL)
End If
hDC = GetDC(ListBoxHandle)
SelectObject hDC, ListBoxFontHandle
For i = 0 To Count - 1
Length = SendMessage(ListBoxHandle, LB_GETTEXTLEN, i, ByVal 0&)
If Not Length = LB_ERR Then
Text = String(Length, vbNullChar)
SendMessage ListBoxHandle, LB_GETTEXT, i, ByVal StrPtr(Text)
GetTextExtentPoint32 hDC, ByVal StrPtr(Text), Length, Size
If (Size.cx - ScrollWidth) > cx Then cx = (Size.cx - ScrollWidth)
End If
Next i
ReleaseDC ListBoxHandle, hDC
If cx > 0 Then GetIdealHorizontalExtent = UserControl.ScaleX(cx + ((RC(0).Right - RC(0).Left) - (RC(1).Right - RC(1).Left)), vbPixels, vbContainerSize)
End If
End If
End Function
Public Function SelectItem(ByVal Text As String, Optional ByVal Index As Long = -1) As Long
If ListBoxHandle <> 0 Then
If Not SendMessage(ListBoxHandle, LB_GETTEXTLEN, Index, ByVal 0&) = LB_ERR Or Index = -1 Then
SelectItem = SendMessage(ListBoxHandle, LB_SELECTSTRING, Index, ByVal StrPtr(Text))
Else
ERR.Raise 381
End If
End If
End Function
Private Sub SetItemCheck(Optional ByVal Index As Long = LB_ERR)
If ListBoxHandle <> 0 Then
If Index = LB_ERR Then Index = SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&)
If Not Index = LB_ERR Then
If Index <= (ListBoxItemCheckedCount - 1) Then
Dim Changed As Boolean
If PropStyle = LstStyleCheckbox Then
Changed = True
ElseIf PropStyle = LstStyleOption Then
Changed = CBool(ListBoxOptionIndex <> Index)
End If
If Changed = True Then
Dim Cancel As Boolean
RaiseEvent ItemBeforeCheck(Index, Cancel)
If Cancel = False Then
Dim RC As RECT
If PropStyle = LstStyleCheckbox Then
Select Case ListBoxItemChecked(Index + 1)
Case vbChecked
ListBoxItemChecked(Index + 1) = vbUnchecked
Case Else
ListBoxItemChecked(Index + 1) = vbChecked
End Select
ElseIf PropStyle = LstStyleOption Then
If ListBoxOptionIndex > -1 Then
SendMessage ListBoxHandle, LB_GETITEMRECT, ListBoxOptionIndex, ByVal VarPtr(RC)
InvalidateRect ListBoxHandle, RC, 0
End If
ListBoxOptionIndex = Index
End If
SendMessage ListBoxHandle, LB_GETITEMRECT, Index, ByVal VarPtr(RC)
InvalidateRect ListBoxHandle, RC, 0
RaiseEvent ItemCheck(Index)
End If
End If
End If
End If
End If
End Sub
Private Function CheckTopIndex() As Boolean
Dim TopIndex As Long
If ListBoxHandle <> 0 Then TopIndex = SendMessage(ListBoxHandle, LB_GETTOPINDEX, 0, ByVal 0&)
If TopIndex <> ListBoxTopIndex Then
ListBoxTopIndex = TopIndex
If ListBoxInsertMark > -1 Then Call InvalidateInsertMark
RaiseEvent Scroll
CheckTopIndex = True
End If
End Function
Private Sub InvalidateInsertMark()
If ListBoxHandle <> 0 Then
If SendMessage(ListBoxHandle, LB_GETTEXTLEN, ListBoxInsertMark, ByVal 0&) = LB_ERR Then Exit Sub
Dim RC As RECT
SendMessage ListBoxHandle, LB_GETITEMRECT, ListBoxInsertMark, ByVal VarPtr(RC)
If ListBoxInsertMarkAfter = False Then
RC.Bottom = RC.Top + 1
RC.Top = RC.Top - 1
Else
RC.Top = RC.Bottom - 1
RC.Bottom = RC.Bottom + 1
End If
RC.Top = RC.Top - 2
RC.Bottom = RC.Bottom + 2
InvalidateRect ListBoxHandle, RC, 1
End If
End Sub
Private Sub DrawInsertMark()
If ListBoxHandle <> 0 Then
If SendMessage(ListBoxHandle, LB_GETTEXTLEN, ListBoxInsertMark, ByVal 0&) = LB_ERR Then Exit Sub
Dim RC As RECT, hRgn As Long, hDC As Long, Brush As Long, OldBrush As Long
GetClientRect ListBoxHandle, RC
hDC = GetDC(ListBoxHandle)
If hDC <> 0 Then
hRgn = CreateRectRgnIndirect(RC)
If hRgn <> 0 Then ExtSelectClipRgn hDC, hRgn, RGN_COPY
SendMessage ListBoxHandle, LB_GETITEMRECT, ListBoxInsertMark, ByVal VarPtr(RC)
If ListBoxInsertMarkAfter = False Then
RC.Bottom = RC.Top + 1
RC.Top = RC.Top - 1
Else
RC.Top = RC.Bottom - 1
RC.Bottom = RC.Bottom + 1
End If
Brush = CreateSolidBrush(WinColor(PropInsertMarkColor))
If Brush <> 0 Then OldBrush = SelectObject(hDC, Brush)
PatBlt hDC, RC.Left, RC.Top - 2, 1, 6, vbPatCopy
PatBlt hDC, RC.Left + 1, RC.Top - 1, 1, 4, vbPatCopy
PatBlt hDC, RC.Left + 2, RC.Top, RC.Right - RC.Left - 2, RC.Bottom - RC.Top, vbPatCopy
PatBlt hDC, RC.Right - 2, RC.Top - 1, 1, 4, vbPatCopy
PatBlt hDC, RC.Right - 1, RC.Top - 2, 1, 6, vbPatCopy
If OldBrush <> 0 Then SelectObject hDC, OldBrush
If Brush <> 0 Then DeleteObject Brush
If hRgn <> 0 Then
ExtSelectClipRgn hDC, 0, RGN_COPY
DeleteObject hRgn
End If
ReleaseDC ListBoxHandle, hDC
End If
End If
End Sub
Private Function ISubclass_Message(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal dwRefData As Long) As Long
Select Case dwRefData
Case 1
ISubclass_Message = WindowProcControl(hwnd, wMsg, wParam, lParam)
Case 2
ISubclass_Message = WindowProcUserControl(hwnd, wMsg, wParam, lParam)
Case 3
ISubclass_Message = WindowProcUserControlDesignMode(hwnd, wMsg, wParam, lParam)
End Select
End Function
Private Function WindowProcControl(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case wMsg
Case WM_SETFOCUS
If wParam <> UserControl.hwnd Then SetFocusAPI UserControl.hwnd: Exit Function
Call ActivateIPAO(Me)
Case WM_KILLFOCUS
Call DeActivateIPAO
Case WM_KEYDOWN, WM_KEYUP, WM_SYSKEYDOWN, WM_SYSKEYUP
Dim KeyCode As Integer
KeyCode = wParam And &HFF&
If wMsg = WM_KEYDOWN Or wMsg = WM_KEYUP Then
If wMsg = WM_KEYDOWN Then
RaiseEvent KeyDown(KeyCode, GetShiftStateFromMsg())
If PropStyle <> LstStyleStandard And KeyCode = vbKeySpace Then Call SetItemCheck
ElseIf wMsg = WM_KEYUP Then
RaiseEvent KeyUp(KeyCode, GetShiftStateFromMsg())
End If
ListBoxCharCodeCache = ComCtlsPeekCharCode(hwnd)
ElseIf wMsg = WM_SYSKEYDOWN Then
RaiseEvent KeyDown(KeyCode, GetShiftStateFromMsg())
ElseIf wMsg = WM_SYSKEYUP Then
RaiseEvent KeyUp(KeyCode, GetShiftStateFromMsg())
End If
wParam = KeyCode
Case WM_CHAR
Dim KeyChar As Integer
If ListBoxCharCodeCache <> 0 Then
KeyChar = CUIntToInt(ListBoxCharCodeCache And &HFFFF&)
ListBoxCharCodeCache = 0
Else
KeyChar = CUIntToInt(wParam And &HFFFF&)
End If
RaiseEvent KeyPress(KeyChar)
wParam = CIntToUInt(KeyChar)
Case WM_UNICHAR
If wParam = UNICODE_NOCHAR Then WindowProcControl = 1 Else SendMessage hwnd, WM_CHAR, wParam, ByVal lParam
Exit Function
Case WM_IME_CHAR
SendMessage hwnd, WM_CHAR, wParam, ByVal lParam
Exit Function
Case WM_MOUSEACTIVATE
Static InProc As Boolean
If ListBoxTopDesignMode = False And GetFocus() <> ListBoxHandle Then
If InProc = True Or LoWord(lParam) = HTBORDER Then WindowProcControl = MA_ACTIVATEANDEAT: Exit Function
Select Case HiWord(lParam)
Case WM_LBUTTONDOWN
On Error Resume Next
With UserControl
If .Extender.CausesValidation = True Then
InProc = True
Call ComCtlsTopParentValidateControls(Me)
InProc = False
If ERR.Number = 380 Then
WindowProcControl = MA_ACTIVATEANDEAT
Else
SetFocusAPI .hwnd
WindowProcControl = MA_NOACTIVATE
End If
Else
SetFocusAPI .hwnd
WindowProcControl = MA_NOACTIVATE
End If
End With
On Error GoTo 0
Exit Function
End Select
End If
Case WM_SETCURSOR
If LoWord(lParam) = HTCLIENT Then
If MousePointerID(PropMousePointer) <> 0 Then
SetCursor LoadCursor(0, MousePointerID(PropMousePointer))
WindowProcControl = 1
Exit Function
ElseIf PropMousePointer = 99 Then
If Not PropMouseIcon Is Nothing Then
SetCursor PropMouseIcon.Handle
WindowProcControl = 1
Exit Function
End If
End If
End If
Case WM_LBUTTONDOWN
Dim Index As Long, IgnoreItemCheck As Boolean, P1 As POINTAPI, RC As RECT
P1.X = Get_X_lParam(lParam)
P1.Y = Get_Y_lParam(lParam)
ClientToScreen ListBoxHandle, P1
If PropOLEDragMode = vbOLEDragAutomatic Then
Index = LBItemFromPt(ListBoxHandle, P1.X, P1.Y, 0)
If Index > -1 Then
If SendMessage(ListBoxHandle, LB_GETSEL, Index, ByVal 0&) > 0 Then
If DragDetect(ListBoxHandle, CUIntToInt(P1.X And &HFFFF&), CUIntToInt(P1.Y And &HFFFF&)) <> 0 Then
ListBoxDragIndexBuffer = Index + 1
Me.OLEDrag
ListBoxDragIndexBuffer = 0
Else
If PropStyle <> LstStyleStandard Then
If Index <> SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&) Then
SendMessage ListBoxHandle, LB_GETITEMRECT, Index, ByVal VarPtr(RC)
If PropRightToLeft = False Then
IgnoreItemCheck = CBool(Get_X_lParam(lParam) >= (RC.Left + ListBoxStateImageSize))
Else
IgnoreItemCheck = CBool(Get_X_lParam(lParam) < (RC.Right - ListBoxStateImageSize))
End If
End If
End If
WindowProcControl = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
If PropStyle <> LstStyleStandard Then If IgnoreItemCheck = False Then Call SetItemCheck(Index)
RaiseEvent MouseDown(vbLeftButton, GetShiftStateFromParam(wParam), UserControl.ScaleX(P1.X, vbPixels, vbTwips), UserControl.ScaleY(P1.Y, vbPixels, vbTwips))
ReleaseCapture
End If
Exit Function
ElseIf PropStyle <> LstStyleStandard Then
If Index <> SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&) Then
SendMessage ListBoxHandle, LB_GETITEMRECT, Index, ByVal VarPtr(RC)
If PropRightToLeft = False Then
IgnoreItemCheck = CBool(Get_X_lParam(lParam) >= (RC.Left + ListBoxStateImageSize))
Else
IgnoreItemCheck = CBool(Get_X_lParam(lParam) < (RC.Right - ListBoxStateImageSize))
End If
End If
WindowProcControl = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
RaiseEvent MouseDown(vbLeftButton, GetShiftStateFromParam(wParam), UserControl.ScaleX(P1.X, vbPixels, vbTwips), UserControl.ScaleY(P1.Y, vbPixels, vbTwips))
If IgnoreItemCheck = False Then Call SetItemCheck(Index)
Exit Function
End If
End If
ElseIf PropStyle <> LstStyleStandard Then
Index = LBItemFromPt(ListBoxHandle, P1.X, P1.Y, 0)
If Index > -1 Then
If Index <> SendMessage(ListBoxHandle, LB_GETCURSEL, 0, ByVal 0&) Then
SendMessage ListBoxHandle, LB_GETITEMRECT, Index, ByVal VarPtr(RC)
If PropRightToLeft = False Then
IgnoreItemCheck = CBool(Get_X_lParam(lParam) >= (RC.Left + ListBoxStateImageSize))
Else
IgnoreItemCheck = CBool(Get_X_lParam(lParam) < (RC.Right - ListBoxStateImageSize))
End If
End If
WindowProcControl = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
RaiseEvent MouseDown(vbLeftButton, GetShiftStateFromParam(wParam), UserControl.ScaleX(P1.X, vbPixels, vbTwips), UserControl.ScaleY(P1.Y, vbPixels, vbTwips))
If IgnoreItemCheck = False Then Call SetItemCheck(Index)
Exit Function
End If
End If
Case WM_CONTEXTMENU
If wParam = ListBoxHandle Then
Dim P2 As POINTAPI
P2.X = Get_X_lParam(lParam)
P2.Y = Get_Y_lParam(lParam)
If P2.X > 0 And P2.Y > 0 Then
ScreenToClient ListBoxHandle, P2
RaiseEvent ContextMenu(UserControl.ScaleX(P2.X, vbPixels, vbContainerPosition), UserControl.ScaleY(P2.Y, vbPixels, vbContainerPosition))
ElseIf P2.X = -1 And P2.Y = -1 Then
' If the user types SHIFT + F10 then the X and Y coordinates are -1.
RaiseEvent ContextMenu(-1, -1)
End If
End If
Case WM_HSCROLL, WM_VSCROLL
If Not (wMsg = WM_HSCROLL And PropMultiColumn = False) Then
Select Case LoWord(wParam)
Case SB_THUMBPOSITION, SB_THUMBTRACK
' HiWord carries only 16 bits of scroll box position data.
' Below workaround will circumvent the 16-bit barrier by using the 32-bit GetScrollInfo function.
Dim dwStyle As Long
dwStyle = GetWindowLong(ListBoxHandle, GWL_STYLE)
If lParam = 0 And ((wMsg = WM_HSCROLL And (dwStyle And WS_HSCROLL) = WS_HSCROLL) Or (wMsg = WM_VSCROLL And (dwStyle And WS_VSCROLL) = WS_VSCROLL)) Then
Dim SCI As SCROLLINFO, wBar As Long, PrevPos As Long
SCI.cbSize = LenB(SCI)
SCI.fMask = SIF_POS Or SIF_TRACKPOS
If wMsg = WM_HSCROLL Then
wBar = SB_HORZ
ElseIf wMsg = WM_VSCROLL Then
wBar = SB_VERT
End If
GetScrollInfo ListBoxHandle, wBar, SCI
PrevPos = SCI.nPos
Select Case LoWord(wParam)
Case SB_THUMBPOSITION
SCI.nPos = SCI.nTrackPos
Case SB_THUMBTRACK
If PropScrollTrack = True Then SCI.nPos = SCI.nTrackPos
End Select
If PrevPos <> SCI.nPos Then
If wMsg = WM_HSCROLL And PropMultiColumn = True Then SCI.nPos = SCI.nPos * Me.ItemsPerColumn
' SetScrollInfo function not needed as LB_SETTOPINDEX itself will do the scrolling.
SendMessage ListBoxHandle, LB_SETTOPINDEX, SCI.nPos, ByVal 0&
End If
WindowProcControl = 0
Exit Function
End If
End Select
End If
End Select
WindowProcControl = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
Select Case wMsg
Case WM_LBUTTONDOWN, WM_MBUTTONDOWN, WM_RBUTTONDOWN, WM_MOUSEMOVE, WM_LBUTTONUP, WM_MBUTTONUP, WM_RBUTTONUP
Dim X As Single
Dim Y As Single
X = UserControl.ScaleX(Get_X_lParam(lParam), vbPixels, vbTwips)
Y = UserControl.ScaleY(Get_Y_lParam(lParam), vbPixels, vbTwips)
Select Case wMsg
Case WM_LBUTTONDOWN
RaiseEvent MouseDown(vbLeftButton, GetShiftStateFromParam(wParam), X, Y)
Case WM_MBUTTONDOWN
RaiseEvent MouseDown(vbMiddleButton, GetShiftStateFromParam(wParam), X, Y)
Case WM_RBUTTONDOWN
RaiseEvent MouseDown(vbRightButton, GetShiftStateFromParam(wParam), X, Y)
Case WM_MOUSEMOVE
If (GetMouseStateFromParam(wParam) And vbLeftButton) = vbLeftButton Then
If CheckTopIndex() = False And ListBoxInsertMark > -1 Then Call InvalidateInsertMark
End If
If ListBoxMouseOver = False And PropMouseTrack = True Then
ListBoxMouseOver = True
RaiseEvent MouseEnter
Call ComCtlsRequestMouseLeave(hwnd)
End If
RaiseEvent MouseMove(GetMouseStateFromParam(wParam), GetShiftStateFromParam(wParam), X, Y)
Case WM_LBUTTONUP, WM_MBUTTONUP, WM_RBUTTONUP
Select Case wMsg
Case WM_LBUTTONUP
RaiseEvent MouseUp(vbLeftButton, GetShiftStateFromParam(wParam), X, Y)
Case WM_MBUTTONUP
RaiseEvent MouseUp(vbMiddleButton, GetShiftStateFromParam(wParam), X, Y)
Case WM_RBUTTONUP
RaiseEvent MouseUp(vbRightButton, GetShiftStateFromParam(wParam), X, Y)
End Select
End Select
Case WM_MOUSELEAVE
If ListBoxMouseOver = True Then
ListBoxMouseOver = False
RaiseEvent MouseLeave
End If
Case WM_MOUSEWHEEL, WM_HSCROLL, WM_VSCROLL, LB_SETTOPINDEX
If CheckTopIndex() = False And ListBoxInsertMark > -1 Then Call InvalidateInsertMark
Case WM_PAINT
If ListBoxInsertMark > -1 Then Call DrawInsertMark
End Select
End Function
Private Function WindowProcUserControl(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case wMsg
Case WM_COMMAND
If lParam = ListBoxHandle Then
Select Case HiWord(wParam)
Case LBN_SELCHANGE
If CheckTopIndex() = False And ListBoxInsertMark > -1 Then Call InvalidateInsertMark
RaiseEvent Click
Case LBN_SELCANCEL
If ListBoxInsertMark > -1 Then Call InvalidateInsertMark
RaiseEvent Click
Case LBN_DBLCLK
RaiseEvent DblClick
End Select
End If
Case WM_MEASUREITEM
If PropDrawMode = LstDrawModeOwnerDrawVariable Then
Dim MIS As MEASUREITEMSTRUCT
CopyMemory MIS, ByVal lParam, LenB(MIS)
If MIS.CtlType = ODT_LISTBOX And MIS.ItemID > -1 Then
With MIS
RaiseEvent ItemMeasure(.ItemID, .ItemHeight)
End With
CopyMemory ByVal lParam, MIS, LenB(MIS)
WindowProcUserControl = 1
Exit Function
End If
End If
Case WM_DRAWITEM
Dim DIS As DRAWITEMSTRUCT
CopyMemory DIS, ByVal lParam, LenB(DIS)
If DIS.CtlType = ODT_LISTBOX And DIS.hWndItem = ListBoxHandle And DIS.ItemID > -1 Then
If PropStyle <> LstStyleStandard Then
Dim BackColorBrush As Long, BackColorSelBrush As Long
BackColorBrush = CreateSolidBrush(WinColor(UserControl.BackColor))
If (DIS.ItemState And ODS_SELECTED) = ODS_SELECTED And PropAllowSelection = True Then BackColorSelBrush = CreateSolidBrush(WinColor(vbHighlight))
Dim RC As RECT
With DIS.RCItem
If PropRightToLeft = False Then
SetRect RC, .Left + 1, .Top + 1, .Left + ListBoxStateImageSize - 1, .Bottom - 1
.Left = .Left + ListBoxStateImageSize
Else
SetRect RC, .Right - ListBoxStateImageSize + 1, .Top + 1, .Right - 1, .Bottom - 1
.Right = .Right - ListBoxStateImageSize
End If
End With
If BackColorSelBrush <> 0 Then
FillRect DIS.hDC, DIS.RCItem, BackColorSelBrush
DeleteObject BackColorSelBrush
Else
FillRect DIS.hDC, DIS.RCItem, BackColorBrush
End If
FillRect DIS.hDC, RC, BackColorBrush
DeleteObject BackColorBrush
#If ImplementThemedButton = True Then
Dim Theme As Long
If EnabledVisualStyles() = True And PropVisualStyles = True Then Theme = OpenThemeData(ListBoxHandle, StrPtr("Button"))
If Theme <> 0 Then
Dim ButtonPart As Long, CheckState As Long
If PropStyle = LstStyleCheckbox Then
ButtonPart = BP_CHECKBOX
If Not (DIS.ItemState And ODS_DISABLED) = ODS_DISABLED Then
CheckState = CBS_UNCHECKEDNORMAL
Else
CheckState = CBS_UNCHECKEDDISABLED
End If
If DIS.ItemID <= (ListBoxItemCheckedCount - 1) Then
If ListBoxItemChecked(DIS.ItemID + 1) = vbChecked Then
If Not (DIS.ItemState And ODS_DISABLED) = ODS_DISABLED Then
CheckState = CBS_CHECKEDNORMAL
Else
CheckState = CBS_CHECKEDDISABLED
End If
End If
End If
ElseIf PropStyle = LstStyleOption Then
ButtonPart = BP_RADIOBUTTON
If Not (DIS.ItemState And ODS_DISABLED) = ODS_DISABLED Then
CheckState = RBS_UNCHECKEDNORMAL
Else
CheckState = RBS_UNCHECKEDDISABLED
End If
If DIS.ItemID <= (ListBoxItemCheckedCount - 1) Then
If ListBoxOptionIndex = DIS.ItemID Then
If Not (DIS.ItemState And ODS_DISABLED) = ODS_DISABLED Then
CheckState = CBS_CHECKEDNORMAL
Else
CheckState = CBS_CHECKEDDISABLED
End If
End If
End If
End If
If IsThemeBackgroundPartiallyTransparent(Theme, ButtonPart, CheckState) <> 0 Then DrawThemeParentBackground DIS.hWndItem, DIS.hDC, RC
DrawThemeBackground Theme, DIS.hDC, ButtonPart, CheckState, RC, RC
CloseThemeData Theme
Else
Dim Flags As Long
Flags = DFCS_FLAT
If (DIS.ItemState And ODS_DISABLED) = ODS_DISABLED Then Flags = Flags Or DFCS_INACTIVE
If PropStyle = LstStyleCheckbox Then
Flags = Flags Or DFCS_BUTTONCHECK
If DIS.ItemID <= (ListBoxItemCheckedCount - 1) Then
If ListBoxItemChecked(DIS.ItemID + 1) = vbChecked Then Flags = Flags Or DFCS_CHECKED
End If
ElseIf PropStyle = LstStyleOption Then
Flags = Flags Or DFCS_BUTTONRADIO
If DIS.ItemID <= (ListBoxItemCheckedCount - 1) Then
If ListBoxOptionIndex = DIS.ItemID Then Flags = Flags Or DFCS_CHECKED
End If
End If
DrawFrameControl DIS.hDC, RC, DFC_BUTTON, Flags
End If
#Else
Dim Flags As Long
Flags = DFCS_FLAT
If (DIS.ItemState And ODS_DISABLED) = ODS_DISABLED Then Flags = Flags Or DFCS_INACTIVE
If PropStyle = LstStyleCheckbox Then
Flags = Flags Or DFCS_BUTTONCHECK
If DIS.ItemID <= (ListBoxItemCheckedCount - 1) Then
If ListBoxItemChecked(DIS.ItemID + 1) = vbChecked Then Flags = Flags Or DFCS_CHECKED
End If
ElseIf PropStyle = LstStyleOption Then
Flags = Flags Or DFCS_BUTTONRADIO
If DIS.ItemID <= (ListBoxItemCheckedCount - 1) Then
If ListBoxOptionIndex = DIS.ItemID Then Flags = Flags Or DFCS_CHECKED
End If
End If
DrawFrameControl DIS.hDC, RC, DFC_BUTTON, Flags
#End If
Dim Length As Long
Length = SendMessage(ListBoxHandle, LB_GETTEXTLEN, DIS.ItemID, ByVal 0&)
If Not Length = LB_ERR Then
Dim Text As String
Text = String(Length, vbNullChar)
SendMessage ListBoxHandle, LB_GETTEXT, DIS.ItemID, ByVal StrPtr(Text)
Dim OldTextAlign As Long, OldBkMode As Long, OldTextColor As Long
If PropRightToLeft = True Then OldTextAlign = SetTextAlign(DIS.hDC, TA_RTLREADING Or TA_RIGHT)
OldBkMode = SetBkMode(DIS.hDC, 1)
If (DIS.ItemState And ODS_DISABLED) = ODS_DISABLED Then
OldTextColor = SetTextColor(DIS.hDC, WinColor(vbGrayText))
ElseIf (DIS.ItemState And ODS_SELECTED) = ODS_SELECTED And PropAllowSelection = True Then
OldTextColor = SetTextColor(DIS.hDC, WinColor(vbHighlightText))
Else
OldTextColor = SetTextColor(DIS.hDC, WinColor(Me.ForeColor))
End If
If PropRightToLeft = False Then
TextOut DIS.hDC, DIS.RCItem.Left + (1 * PixelsPerDIP_X()), DIS.RCItem.Top, StrPtr(Text), Length
Else
TextOut DIS.hDC, DIS.RCItem.Right - (1 * PixelsPerDIP_X()), DIS.RCItem.Top, StrPtr(Text), Length
End If
SetBkMode DIS.hDC, OldBkMode
SetTextColor DIS.hDC, OldTextColor
If PropRightToLeft = True Then SetTextAlign DIS.hDC, OldTextAlign
End If
If (DIS.ItemState And ODS_FOCUS) = ODS_FOCUS Then DrawFocusRect DIS.hDC, DIS.RCItem
Else
With DIS
RaiseEvent ItemDraw(.ItemID, .ItemAction, .ItemState, .hDC, .RCItem.Left, .RCItem.Top, .RCItem.Right, .RCItem.Bottom)
End With
End If
WindowProcUserControl = 1
Exit Function
End If
End Select
WindowProcUserControl = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
If wMsg = WM_SETFOCUS Then SetFocusAPI ListBoxHandle
End Function
Private Function WindowProcUserControlDesignMode(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If wMsg = WM_DRAWITEM Then
WindowProcUserControlDesignMode = WindowProcUserControl(hwnd, wMsg, wParam, lParam)
Exit Function
End If
WindowProcUserControlDesignMode = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
Select Case wMsg
Case WM_DESTROY, WM_NCDESTROY
Call ComCtlsRemoveSubclass(hwnd)
Case WM_STYLECHANGED
Dim dwStyleOld As Long, dwStyleNew As Long
CopyMemory dwStyleOld, ByVal lParam, 4
CopyMemory dwStyleNew, ByVal UnsignedAdd(lParam, 4), 4
If dwStyleOld = dwStyleNew Then Call ComCtlsRemoveSubclass(hwnd)
End Select
End Function

复制代码

Sbutton.ctl

Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
'事件************************************
Public Event Click() '鼠标单击
Public Event Hover() '鼠标悬停
Public Event MouseLeave() '鼠标离开
'常量************************************
Const FORECOLORUNABLE As Long = &H80000011 '不可用时的文本颜色
Const BACKCOLORUNABLE As Long = &H8000000F '不可用时的背景颜色
Const BORDERCOLORUNABLE As Long = &H80000015 '不可用时的边框颜色
'枚举************************************
Public Enum pBorderStyle_SButton
无边框
有边框
End Enum
Public Enum pState_SButton
mNormal
mHover
mClick
End Enum
'存储的属性值***************************
Private cBackColorClick As OLE_COLOR '鼠标单击时的背景颜色
Private cBackColorHover As OLE_COLOR '鼠标悬停时的背景颜色
Private cBackColorNormal As OLE_COLOR '默认状态下的背景颜色
Private cBorderColorClick As OLE_COLOR '鼠标单击时的边框颜色
Private cBorderColorHover As OLE_COLOR '鼠标悬停时的边框颜色
Private cBorderColorNormal As OLE_COLOR '默认状态下的边框颜色
Private cBorderStyle As pBorderStyle_SButton '边框样式，0 - 无边框；1 - 有边框
Private cCaption As String '标题
Private cEnabled As Boolean '有效性
Private cFont As Font '字体样式
Private cForeColorClick As OLE_COLOR '鼠标单击时的文本颜色
Private cForeColorHover As OLE_COLOR '鼠标悬停时的文本颜色
Private cForeColorNormal As OLE_COLOR '默认状态下的文本颜色
Private cState As pState_SButton '鼠标状态
'重设控件：控件值改变时执行
Private Sub RedrawControl()
Select Case cState
Case mNormal
UserControl.BackColor = cBackColorNormal
Shape1.BorderColor = cBorderColorNormal
Label1.ForeColor = cForeColorNormal
Case mHover
UserControl.BackColor = cBackColorHover
Shape1.BorderColor = cBorderColorHover
Label1.ForeColor = cForeColorHover
Case mClick
UserControl.BackColor = cBackColorClick
Shape1.BorderColor = cBorderColorClick
Label1.ForeColor = cForeColorClick
End Select
Shape1.Visible = (cBorderStyle = 有边框)
Set Label1.Font = cFont
Label1.Caption = cCaption
UserControl.Enabled = cEnabled
Label1.Move UserControl.Width / 2 - Label1.Width / 2, UserControl.Height / 2 - Label1.Height / 2 '居中标签
If cEnabled = False Then
UserControl.BackColor = BACKCOLORUNABLE
Label1.ForeColor = FORECOLORUNABLE
Shape1.BorderColor = BORDERCOLORUNABLE
End If
Shape1.Move 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight
End Sub
'响应的事件处理************************
Private Sub Label1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If cEnabled = False Then Exit Sub
If cEnabled = False Then Exit Sub
If Button = 1 Then
RaiseEvent Click
cState = mClick
RedrawControl
End If
End Sub
Private Sub Label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If cEnabled = False Then Exit Sub
If Button <> 0 Then Exit Sub
If cState = mNormal Then
cState = mHover
RedrawControl
End If
RaiseEvent Hover
End Sub
Private Sub Label1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If cEnabled = False Then Exit Sub
cState = mHover
RedrawControl
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If cEnabled = False Then Exit Sub
If Button = 1 Then
RaiseEvent Click
cState = mClick
RedrawControl
End If
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If X >= 0 And X <= UserControl.Width And Y >= 0 And Y <= UserControl.Height Then
'移入
If cEnabled = False Then Exit Sub
If Button <> 0 Then Exit Sub
If cState = mNormal Then
cState = mHover
RedrawControl
End If
RaiseEvent Hover
SetCapture UserControl.hwnd
Else
'移出
If cState <> mNormal Then cState = mNormal
RedrawControl
ReleaseCapture
End If
End Sub
'属性的读写*****************************
Public Property Get BackColorClick() As OLE_COLOR '获得鼠标按下时背景颜色
BackColorClick = cBackColorClick
End Property
Public Property Let BackColorClick(ByVal nV As OLE_COLOR) '写入鼠标按下时背景颜色
cBackColorClick = nV
RedrawControl
PropertyChanged "BackColorClick"
End Property
'██████████
Public Property Get BackColorHover() As OLE_COLOR '获得鼠标悬停时背景颜色
BackColorHover = cBackColorHover
End Property
Public Property Let BackColorHover(ByVal nV As OLE_COLOR) '写入鼠标悬停时背景颜色
cBackColorHover = nV
RedrawControl
PropertyChanged "BackColorHover"
End Property
'██████████
Public Property Get BackColorNormal() As OLE_COLOR '获得正常状态时背景颜色
BackColorNormal = cBackColorNormal
End Property
Public Property Let BackColorNormal(ByVal nV As OLE_COLOR) '写入正常状态时背景颜色
cBackColorNormal = nV
RedrawControl
PropertyChanged "BackColorNormal"
End Property
'██████████
Public Property Get BorderColorClick() As OLE_COLOR '获得鼠标按下时边框颜色
BorderColorClick = cBorderColorClick
End Property
Public Property Let BorderColorClick(ByVal nV As OLE_COLOR) '写入鼠标按下时边框颜色
cBorderColorClick = nV
RedrawControl
PropertyChanged "BorderColorClick"
End Property
'██████████
Public Property Get BorderColorHover() As OLE_COLOR '获得鼠标悬停时边框颜色
BorderColorHover = cBorderColorHover
End Property
Public Property Let BorderColorHover(ByVal nV As OLE_COLOR) '写入鼠标悬停时边框颜色
cBorderColorHover = nV
RedrawControl
PropertyChanged "BorderColorHover"
End Property
'██████████
Public Property Get BorderColorNormal() As OLE_COLOR '获得正常状态时边框颜色
BorderColorNormal = cBorderColorNormal
End Property
Public Property Let BorderColorNormal(ByVal nV As OLE_COLOR) '写入正常状态时边框颜色
cBorderColorNormal = nV
RedrawControl
PropertyChanged "BorderColorNormal"
End Property
'██████████
Public Property Get ForeColorClick() As OLE_COLOR '获得鼠标按下时文本颜色
ForeColorClick = cForeColorClick
End Property
Public Property Let ForeColorClick(ByVal nV As OLE_COLOR) '写入鼠标按下时文本颜色
cForeColorClick = nV
RedrawControl
PropertyChanged "ForeColorClick"
End Property
'██████████
Public Property Get ForeColorHover() As OLE_COLOR '获得鼠标悬停时文本颜色
ForeColorHover = cForeColorHover
End Property
Public Property Let ForeColorHover(ByVal nV As OLE_COLOR) '写入鼠标悬停时文本颜色
cForeColorHover = nV
RedrawControl
PropertyChanged "ForeColorHover"
End Property
'██████████
Public Property Get ForeColorNormal() As OLE_COLOR '获得正常状态时文本颜色
ForeColorNormal = cForeColorNormal
End Property
Public Property Let ForeColorNormal(ByVal nV As OLE_COLOR) '写入正常状态时文本颜色
cForeColorNormal = nV
RedrawControl
PropertyChanged "ForeColorNormal"
End Property
'██████████
Public Property Get BorderStyle() As pBorderStyle_SButton '获得边框样式
BorderStyle = cBorderStyle
End Property
Public Property Let BorderStyle(ByVal nV As pBorderStyle_SButton) '写入边框样式
cBorderStyle = nV
RedrawControl
PropertyChanged "BorderStyle"
End Property
'██████████
Public Property Get Caption() As String '获得文本
Caption = cCaption
End Property
Public Property Let Caption(ByVal nV As String) '写入文本
cCaption = nV
RedrawControl
PropertyChanged "Caption"
End Property
'██████████
Public Property Get Font() As Font '获得字体
Set Font = cFont
End Property
Public Property Set Font(ByRef nF As Font) '写入字体
Set cFont = nF
Set Label1.Font = cFont
RedrawControl
PropertyChanged "Font"
End Property
'██████████
Public Property Get Enabled() As Boolean '获得有效性
Enabled = cEnabled
End Property
Public Property Let Enabled(ByVal nV As Boolean) '写入有效性
cEnabled = nV
RedrawControl
PropertyChanged "Enabled"
End Property
'██████████
'初始化控件*****************************
Private Sub UserControl_Initialize()
cBackColorClick = RGB(51, 153, 255)
cBackColorHover = RGB(102, 204, 255)
cBackColorNormal = RGB(51, 204, 255)
cBorderColorClick = RGB(0, 0, 0)
cBorderColorHover = RGB(0, 0, 0)
cBorderColorNormal = RGB(0, 0, 0)
cForeColorClick = RGB(255, 255, 255)
cForeColorHover = RGB(255, 255, 255)
cForeColorNormal = RGB(255, 255, 255)
cBorderStyle = 无边框 '不显示边框
cCaption = "SButton"
cEnabled = True
Set cFont = Label2.Font
cState = mNormal
RedrawControl
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If cEnabled = False Then Exit Sub
cState = mHover
RedrawControl
End Sub
'读取属性*******************************
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
cBackColorClick = PropBag.ReadProperty("BackColorClick", RGB(51, 153, 255))
cBackColorHover = PropBag.ReadProperty("BackColorHover", RGB(102, 204, 255))
cBackColorNormal = PropBag.ReadProperty("BackColorNormal", RGB(51, 204, 255))
cBorderColorClick = PropBag.ReadProperty("BorderColorClick", RGB(0, 0, 0))
cBorderColorHover = PropBag.ReadProperty("BorderColorHover", RGB(0, 0, 0))
cBorderColorNormal = PropBag.ReadProperty("BorderColorNormal", RGB(0, 0, 0))
cBorderStyle = PropBag.ReadProperty("BorderStyle", pBorderStyle_SButton.无边框)
cCaption = PropBag.ReadProperty("Caption", "SButton")
cEnabled = PropBag.ReadProperty("Enabled", True)
Set cFont = PropBag.ReadProperty("Font", Label2.Font)
cForeColorClick = PropBag.ReadProperty("ForeColorClick", RGB(255, 255, 255))
cForeColorHover = PropBag.ReadProperty("ForeColorHover", RGB(255, 255, 255))
cForeColorNormal = PropBag.ReadProperty("ForeColorNormal", RGB(255, 255, 255))
RedrawControl
End Sub
'写入属性*******************************
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("BackColorClick", cBackColorClick, RGB(51, 153, 255))
Call PropBag.WriteProperty("BackColorHover", cBackColorHover, RGB(102, 204, 255))
Call PropBag.WriteProperty("BackColorNormal", cBackColorNormal, RGB(51, 204, 255))
Call PropBag.WriteProperty("BorderColorClick", cBorderColorClick, RGB(0, 0, 0))
Call PropBag.WriteProperty("BorderColorHover", cBorderColorHover, RGB(0, 0, 0))
Call PropBag.WriteProperty("BorderColorNormal", cBorderColorNormal, RGB(0, 0, 0))
Call PropBag.WriteProperty("BorderStyle", cBorderStyle, pBorderStyle_SButton.无边框)
Call PropBag.WriteProperty("Caption", cCaption, "SButton")
Call PropBag.WriteProperty("Enabled", cEnabled, True)
Call PropBag.WriteProperty("Font", cFont, Label2.Font)
Call PropBag.WriteProperty("ForeColorClick", cForeColorClick, RGB(255, 255, 255))
Call PropBag.WriteProperty("ForeColorHover", cForeColorHover, RGB(255, 255, 255))
Call PropBag.WriteProperty("ForeColorNormal", cForeColorNormal, RGB(255, 255, 255))
End Sub
'重置尺寸*******************************
Private Sub UserControl_Resize()
Label1.Move UserControl.Width / 2 - Label1.Width / 2, UserControl.Height / 2 - Label1.Height / 2 '居中标签
Shape1.Move 0, 0, UserControl.Width, UserControl.Height
RedrawControl
End Sub

复制代码

SSwitch.ctl

'属性声明
Private cBackColorOff As OLE_COLOR '关闭时的背景色
Private cBackColorOn As OLE_COLOR '开启时的背景色
Private cEnabled As Boolean '有效性
Private cValue As Boolean '值
'事件声明
Public Event Click()
Private Sub Picture1_Click()
If cEnabled = False Then Exit Sub
cValue = Not cValue
RedrawControl
RaiseEvent Click
End Sub
Private Sub Picture2_Click()
If cEnabled = False Then Exit Sub
cValue = Not cValue
RedrawControl
RaiseEvent Click
End Sub
Private Sub UserControl_Click()
If cEnabled = False Then Exit Sub
cValue = Not cValue
RedrawControl
RaiseEvent Click
End Sub
Private Sub RedrawControl()
If cValue = True Then
Picture2.Left = Picture1.Width - 15 - Picture2.Width
Picture1.BackColor = cBackColorOn
Else
Picture2.Left = 15
Picture1.BackColor = cBackColorOff
End If
Shape1.BorderColor = Picture1.BackColor
Shape1.BorderStyle = 1
Picture2.BackColor = RGB(255, 255, 255)
End Sub
'初始化控件
Private Sub UserControl_Initialize()
cValue = False
cBackColorOff = RGB(225, 225, 225)
cBackColorOn = RGB(51, 204, 255)
cBorderColor = RGB(225, 225, 225)
UserControl_Resize
cEnabled = True
RedrawControl
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
cBackColorOff = PropBag.ReadProperty("BackColorOff", RGB(225, 225, 225))
cBackColorOn = PropBag.ReadProperty("BackColorOn", RGB(51, 204, 255))
cValue = PropBag.ReadProperty("Value", False)
cEnabled = PropBag.ReadProperty("Enabled", True)
RedrawControl
End Sub
Private Sub UserControl_Resize()
Picture1.Move 0, 0, UserControl.Width, UserControl.Height
Shape1.Move 0, 0, Picture1.Width, Picture1.Height
Picture2.Top = 15
Picture2.Width = Picture1.Width / 2 - 15
Picture2.Height = Picture1.Height - 30
RedrawControl
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("BackColorOff", cBackColorOff, RGB(225, 225, 225))
Call PropBag.WriteProperty("BackColorOn", cBackColorOn, RGB(51, 204, 255))
Call PropBag.WriteProperty("Enabled", cEnabled, True)
Call PropBag.WriteProperty("Value", cValue, False)
End Sub
'属性的读写*****************************
Public Property Get BackColorOff() As OLE_COLOR
BackColorOff = cBackColorOff
End Property
Public Property Let BackColorOff(ByVal nV As OLE_COLOR)
cBackColorOff = nV
RedrawControl
PropertyChanged "BackColorOff"
End Property
'██████████
Public Property Get BackColorOn() As OLE_COLOR
BackColorOn = cBackColorOn
End Property
Public Property Let BackColorOn(ByVal nV As OLE_COLOR)
cBackColorOn = nV
RedrawControl
PropertyChanged "BackColorOn"
End Property
'██████████
Public Property Get Enabled() As Boolean '获得有效性
Enabled = cEnabled
End Property
Public Property Let Enabled(ByVal nV As Boolean) '写入有效性
cEnabled = nV
RedrawControl
PropertyChanged "Enabled"
End Property
'██████████
Public Property Get Value() As Boolean '获得值
Value = cValue
End Property
Public Property Let Value(ByVal nV As Boolean) '写入值
cValue = nV
RedrawControl
PropertyChanged "Value"
End Property
'██████████

复制代码

TextBoxW

Option Explicit
#If False Then
Private TxtCharacterCasingNormal, TxtCharacterCasingUpper, TxtCharacterCasingLower
Private TxtIconNone, TxtIconInfo, TxtIconWarning, TxtIconError
Private TxtNetAddressFormatNone, TxtNetAddressFormatDNSName, TxtNetAddressFormatIPv4, TxtNetAddressFormatIPv6
Private TxtNetAddressTypeNone, TxtNetAddressTypeIPv4Address, TxtNetAddressTypeIPv4Service, TxtNetAddressTypeIPv4Network, TxtNetAddressTypeIPv6Address, TxtNetAddressTypeIPv6AddressNoScope, TxtNetAddressTypeIPv6Service, TxtNetAddressTypeIPv6ServiceNoScope, TxtNetAddressTypeIPv6Network, TxtNetAddressTypeDNSName, TxtNetAddressTypeDNSService, TxtNetAddressTypeIPAddress, TxtNetAddressTypeIPAddressNoScope, TxtNetAddressTypeIPService, TxtNetAddressTypeIPServiceNoScope, TxtNetAddressTypeIPNetwork, TxtNetAddressTypeAnyAddress, TxtNetAddressTypeAnyAddressNoScope, TxtNetAddressTypeAnyService, TxtNetAddressTypeAnyServiceNoScope
#End If
Public Enum TxtCharacterCasingConstants
TxtCharacterCasingNormal = 0
TxtCharacterCasingUpper = 1
TxtCharacterCasingLower = 2
End Enum
Private Const TTI_NONE As Long = 0
Private Const TTI_INFO As Long = 1
Private Const TTI_WARNING As Long = 2
Private Const TTI_ERROR As Long = 3
Public Enum TxtIconConstants
TxtIconNone = TTI_NONE
TxtIconInfo = TTI_INFO
TxtIconWarning = TTI_WARNING
TxtIconError = TTI_ERROR
End Enum
Private Const NET_ADDRESS_FORMAT_UNSPECIFIED As Long = 0
Private Const NET_ADDRESS_DNS_NAME As Long = 1
Private Const NET_ADDRESS_IPV4 As Long = 2
Private Const NET_ADDRESS_IPV6 As Long = 3
Public Enum TxtNetAddressFormatConstants
TxtNetAddressFormatNone = NET_ADDRESS_FORMAT_UNSPECIFIED
TxtNetAddressFormatDNSName = NET_ADDRESS_DNS_NAME
TxtNetAddressFormatIPv4 = NET_ADDRESS_IPV4
TxtNetAddressFormatIPv6 = NET_ADDRESS_IPV6
End Enum
Public Enum TxtNetAddressTypeConstants
TxtNetAddressTypeNone = 0
TxtNetAddressTypeIPv4Address = 1
TxtNetAddressTypeIPv4Service = 2
TxtNetAddressTypeIPv4Network = 3
TxtNetAddressTypeIPv6Address = 4
TxtNetAddressTypeIPv6AddressNoScope = 5
TxtNetAddressTypeIPv6Service = 6
TxtNetAddressTypeIPv6ServiceNoScope = 7
TxtNetAddressTypeIPv6Network = 8
TxtNetAddressTypeDNSName = 9
TxtNetAddressTypeDNSService = 10
TxtNetAddressTypeIPAddress = 11
TxtNetAddressTypeIPAddressNoScope = 12
TxtNetAddressTypeIPService = 13
TxtNetAddressTypeIPServiceNoScope = 14
TxtNetAddressTypeIPNetwork = 15
TxtNetAddressTypeAnyAddress = 16
TxtNetAddressTypeAnyAddressNoScope = 17
TxtNetAddressTypeAnyService = 18
TxtNetAddressTypeAnyServiceNoScope = 19
End Enum
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type SIZEAPI
cx As Long
cy As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type EDITBALLOONTIP
cbStruct As Long
pszTitle As Long
pszText As Long
iIcon As Long
End Type
Private Type NET_ADDRESS_INFO_UNSPECIFIED
Format As Integer
data(0 To (1024 - 1)) As Byte
End Type
Private Const DNS_MAX_NAME_BUFFER_LENGTH As Long = 256
Private Type NET_ADDRESS_INFO_DNS_NAME
Format As Integer
Address(0 To ((DNS_MAX_NAME_BUFFER_LENGTH * 2) - 1)) As Byte
Port(0 To ((6 * 2) - 1)) As Byte
End Type
Private Type NET_ADDRESS_INFO_IPV4
Format As Integer
sin_family As Integer
sin_port As Integer
sin_addr As Long
sin_zero(0 To (8 - 1)) As Byte
End Type
Private Type NET_ADDRESS_INFO_IPV6
Format As Integer
sin6_family As Integer
sin6_port As Integer
sin6_flowinfoLo As Integer
sin6_flowinfoHi As Integer
sin6_addr(0 To (8 - 1)) As Integer
sin6_scope_idLo As Integer
sin6_scope_idHi As Integer
End Type
Private Type NC_ADDRESS
pAddrInfo As Long ' VarPtr(NET_ADDRESS_INFO_*)
PortNumber As Integer
PrefixLength As Byte
End Type
Public Event Click()
Public Event DblClick()
Public Event Change()
Public Event MaxText()
Public Event Scroll()
Public Event ContextMenu(ByRef Handled As Boolean, ByVal X As Single, ByVal Y As Single)
Public Event PreviewKeyDown(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean)
Public Event PreviewKeyUp(ByVal KeyCode As Integer, ByRef IsInputKey As Boolean)
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyChar As Integer)
Public Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event MouseEnter()
Public Event MouseLeave()
Public Event OLECompleteDrag(Effect As Long)
Public Event OLEDragDrop(data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
Public Event OLEDragOver(data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
Public Event OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean)
Public Event OLESetData(data As DataObject, DataFormat As Integer)
Public Event OLEStartDrag(data As DataObject, AllowedEffects As Long)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Function InitNetworkAddressControl Lib "shell32" () As Long
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExW" (ByVal dwExStyle As Long, ByVal lpClassName As Long, ByVal lpWindowName As Long, ByVal dwStyle As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, ByRef lpParam As Any) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function SetFocusAPI Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Private 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
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongW" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hWndLock As Long) As Long
Private Declare Function EnableWindow Lib "user32" (ByVal hwnd As Long, ByVal fEnable As Long) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, ByVal lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorW" (ByVal hInstance As Long, ByVal lpCursorName As Any) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (ByRef lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, ByRef lpPoint As POINTAPI) As Long
Private Declare Function GetScrollPos Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32W" (ByVal hDC As Long, ByVal lpsz As Long, ByVal cbString As Long, ByRef lpSize As SIZEAPI) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function CreateCaret Lib "user32" (ByVal hwnd As Long, ByVal hBitmap As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SetCaretPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function ShowCaret Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DestroyCaret Lib "user32" () As Long
Private Declare Function DragDetect Lib "user32" (ByVal hwnd As Long, ByVal PX As Integer, ByVal PY As Integer) As Long
Private Const ICC_STANDARD_CLASSES As Long = &H4000
Private Const RDW_UPDATENOW As Long = &H100, RDW_INVALIDATE As Long = &H1, RDW_ERASE As Long = &H4, RDW_ALLCHILDREN As Long = &H80
Private Const GWL_STYLE As Long = (-16)
Private Const CF_UNICODETEXT As Long = 13
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_CHILD As Long = &H40000000
Private Const WS_EX_RTLREADING As Long = &H2000, WS_EX_LEFTSCROLLBAR As Long = &H4000
Private Const WS_HSCROLL As Long = &H100000
Private Const WS_VSCROLL As Long = &H200000
Private Const SB_LINELEFT As Long = 0, SB_LINERIGHT As Long = 1
Private Const SB_LINEUP As Long = 0, SB_LINEDOWN As Long = 1
Private Const SB_THUMBPOSITION = 4, SB_THUMBTRACK As Long = 5
Private Const SB_HORZ As Long = 0, SB_VERT As Long = 1
Private Const WM_MOUSEACTIVATE As Long = &H21, MA_ACTIVATE As Long = &H1, MA_ACTIVATEANDEAT As Long = &H2, MA_NOACTIVATE As Long = &H3, MA_NOACTIVATEANDEAT As Long = &H4, HTBORDER As Long = 18
Private Const SW_HIDE As Long = &H0
Private Const WM_SETFOCUS As Long = &H7
Private Const WM_KILLFOCUS As Long = &H8
Private Const WM_COMMAND As Long = &H111
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const WM_CHAR As Long = &H102
Private Const WM_SYSKEYDOWN As Long = &H104
Private Const WM_SYSKEYUP As Long = &H105
Private Const WM_UNICHAR As Long = &H109, UNICODE_NOCHAR As Long = &HFFFF&
Private Const WM_INPUTLANGCHANGE As Long = &H51
Private Const WM_IME_SETCONTEXT As Long = &H281
Private Const WM_IME_CHAR As Long = &H286
Private Const WM_LBUTTONDOWN As Long = &H201
Private Const WM_LBUTTONUP As Long = &H202
Private Const WM_MBUTTONDOWN As Long = &H207
Private Const WM_MBUTTONUP As Long = &H208
Private Const WM_RBUTTONDOWN As Long = &H204
Private Const WM_RBUTTONUP As Long = &H205
Private Const WM_LBUTTONDBLCLK As Long = &H203
Private Const WM_MBUTTONDBLCLK As Long = &H209
Private Const WM_RBUTTONDBLCLK As Long = &H206
Private Const WM_MOUSEMOVE As Long = &H200
Private Const WM_MOUSELEAVE As Long = &H2A3
Private Const WM_HSCROLL As Long = &H114
Private Const WM_VSCROLL As Long = &H115
Private Const WM_CONTEXTMENU As Long = &H7B
Private Const WM_SETFONT As Long = &H30
Private Const WM_SETCURSOR As Long = &H20, HTCLIENT As Long = 1
Private Const WM_GETTEXTLENGTH As Long = &HE
Private Const WM_GETTEXT As Long = &HD
Private Const WM_SETTEXT As Long = &HC
Private Const WM_COPY As Long = &H301
Private Const WM_CUT As Long = &H300
Private Const WM_PASTE As Long = &H302
Private Const WM_CLEAR As Long = &H303
Private Const WM_USER As Long = &H400
Private Const NCM_GETADDRESS As Long = (WM_USER + 1)
Private Const NCM_SETALLOWTYPE As Long = (WM_USER + 2)
Private Const NCM_GETALLOWTYPE As Long = (WM_USER + 3)
Private Const NCM_DISPLAYERRORTIP As Long = (WM_USER + 4)
Private Const NET_STRING_IPV4_ADDRESS As Long = &H1
Private Const NET_STRING_IPV4_SERVICE As Long = &H2
Private Const NET_STRING_IPV4_NETWORK As Long = &H4
Private Const NET_STRING_IPV6_ADDRESS As Long = &H8
Private Const NET_STRING_IPV6_ADDRESS_NO_SCOPE As Long = &H10
Private Const NET_STRING_IPV6_SERVICE As Long = &H20
Private Const NET_STRING_IPV6_SERVICE_NO_SCOPE As Long = &H40
Private Const NET_STRING_IPV6_NETWORK As Long = &H80
Private Const NET_STRING_NAMED_ADDRESS As Long = &H100
Private Const NET_STRING_NAMED_SERVICE As Long = &H200
Private Const NET_STRING_IP_ADDRESS As Long = (NET_STRING_IPV4_ADDRESS Or NET_STRING_IPV6_ADDRESS)
Private Const NET_STRING_IP_ADDRESS_NO_SCOPE As Long = (NET_STRING_IPV4_ADDRESS Or NET_STRING_IPV6_ADDRESS_NO_SCOPE)
Private Const NET_STRING_IP_SERVICE As Long = (NET_STRING_IPV4_SERVICE Or NET_STRING_IPV6_SERVICE)
Private Const NET_STRING_IP_SERVICE_NO_SCOPE As Long = (NET_STRING_IPV4_SERVICE Or NET_STRING_IPV6_SERVICE_NO_SCOPE)
Private Const NET_STRING_IP_NETWORK As Long = (NET_STRING_IPV4_NETWORK Or NET_STRING_IPV6_NETWORK)
Private Const NET_STRING_ANY_ADDRESS As Long = (NET_STRING_NAMED_ADDRESS Or NET_STRING_IP_ADDRESS)
Private Const NET_STRING_ANY_ADDRESS_NO_SCOPE As Long = (NET_STRING_NAMED_ADDRESS Or NET_STRING_IP_ADDRESS_NO_SCOPE)
Private Const NET_STRING_ANY_SERVICE As Long = (NET_STRING_NAMED_SERVICE Or NET_STRING_IP_SERVICE)
Private Const NET_STRING_ANY_SERVICE_NO_SCOPE As Long = (NET_STRING_NAMED_SERVICE Or NET_STRING_IP_SERVICE_NO_SCOPE)
Private Const EM_SETREADONLY As Long = &HCF, ES_READONLY As Long = &H800
Private Const EM_GETSEL As Long = &HB0
Private Const EM_SETSEL As Long = &HB1
Private Const EM_SCROLL As Long = &HB5
Private Const EM_LINESCROLL As Long = &HB6
Private Const EM_SCROLLCARET As Long = &HB7
Private Const EM_REPLACESEL As Long = &HC2
Private Const EM_GETPASSWORDCHAR As Long = &HD2
Private Const EM_SETPASSWORDCHAR As Long = &HCC
Private Const EM_GETLIMITTEXT As Long = &HD5
Private Const EM_LIMITTEXT As Long = &HC5
Private Const EM_SETLIMITTEXT As Long = EM_LIMITTEXT
Private Const EM_GETMODIFY As Long = &HB8
Private Const EM_SETMODIFY As Long = &HB9
Private Const EM_LINEINDEX As Long = &HBB
Private Const EM_GETTHUMB As Long = &HBE
Private Const EM_LINELENGTH As Long = &HC1
Private Const EM_GETLINE As Long = &HC4
Private Const EM_UNDO As Long = &HC7
Private Const EM_CANUNDO As Long = &HC6
Private Const EM_LINEFROMCHAR As Long = &HC9
Private Const EM_EMPTYUNDOBUFFER As Long = &HCD
Private Const EM_GETFIRSTVISIBLELINE As Long = &HCE
Private Const EM_GETLINECOUNT As Long = &HBA
Private Const EM_GETMARGINS As Long = &HD4
Private Const EM_SETMARGINS As Long = &HD3
Private Const EM_POSFROMCHAR As Long = &HD6
Private Const EM_CHARFROMPOS As Long = &HD7
Private Const ECM_FIRST As Long = &H1500
Private Const EM_SETCUEBANNER As Long = (ECM_FIRST + 1)
Private Const EM_GETCUEBANNER As Long = (ECM_FIRST + 2)
Private Const EM_SHOWBALLOONTIP As Long = (ECM_FIRST + 3)
Private Const EM_HIDEBALLOONTIP As Long = (ECM_FIRST + 4)
Private Const EN_UPDATE As Long = &H400
Private Const EN_CHANGE As Long = &H300
Private Const EN_MAXTEXT As Long = &H501
Private Const EN_HSCROLL As Long = &H601
Private Const EN_VSCROLL As Long = &H602
Private Const ES_AUTOHSCROLL As Long = &H80
Private Const ES_AUTOVSCROLL As Long = &H40
Private Const ES_NUMBER As Long = &H2000
Private Const ES_NOHIDESEL As Long = &H100
Private Const ES_LEFT As Long = &H0
Private Const ES_CENTER As Long = &H1
Private Const ES_RIGHT As Long = &H2
Private Const ES_MULTILINE As Long = &H4
Private Const ES_UPPERCASE As Long = &H8
Private Const ES_LOWERCASE As Long = &H10
Private Const ES_PASSWORD As Long = &H20
Private Const ES_WANTRETURN As Long = &H1000
Private Const EC_LEFTMARGIN As Long = &H1
Private Const EC_RIGHTMARGIN As Long = &H2
Private Const EC_USEFONTINFO As Long = &HFFFF&
Implements ISubclass
Implements OLEGuids.IObjectSafety
Implements OLEGuids.IOleInPlaceActiveObjectVB
Implements OLEGuids.IOleControlVB
Implements OLEGuids.IPerPropertyBrowsingVB
Private TextBoxHandle As Long
Private TextBoxFontHandle As Long
Private TextBoxIMCHandle As Long
Private TextBoxCharCodeCache As Long
Private TextBoxAutoDragInSel As Boolean, TextBoxAutoDragIsActive As Boolean
Private TextBoxIsClick As Boolean
Private TextBoxMouseOver As Boolean
Private TextBoxDesignMode As Boolean, TextBoxTopDesignMode As Boolean
Private TextBoxChangeFrozen As Boolean
Private TextBoxNetAddressFormat As TxtNetAddressFormatConstants
Private TextBoxNetAddressString As String
Private TextBoxNetAddressPortNumber As Integer
Private TextBoxNetAddressPrefixLength As Byte
Private DispIDMousePointer As Long
Private WithEvents PropFont As StdFont
Private PropVisualStyles As Boolean
Private PropOLEDragMode As VBRUN.OLEDragConstants
Private PropOLEDragDropScroll As Boolean
Private PropOLEDropMode As VBRUN.OLEDropConstants
Private PropMousePointer As Integer, PropMouseIcon As IPictureDisp
Private PropMouseTrack As Boolean
Private PropRightToLeft As Boolean
Private PropRightToLeftMode As CCRightToLeftModeConstants
Private PropBorderStyle As CCBorderStyleConstants
Private PropText As String
Private PropAlignment As VBRUN.AlignmentConstants
Private PropAllowOnlyNumbers As Boolean
Private PropLocked As Boolean
Private PropHideSelection As Boolean
Private PropPasswordChar As Integer
Private PropUseSystemPasswordChar As Boolean
Private PropMultiLine As Boolean
Private PropMaxLength As Long
Private PropScrollBars As VBRUN.ScrollBarConstants
Private PropCueBanner As String
Private PropCharacterCasing As TxtCharacterCasingConstants
Private PropWantReturn As Boolean
Private PropIMEMode As CCIMEModeConstants
Private PropNetAddressValidator As Boolean
Private PropNetAddressType As TxtNetAddressTypeConstants
Private PropAllowOverType As Boolean
Private PropOverTypeMode As Boolean
Private Sub IObjectSafety_GetInterfaceSafetyOptions(ByRef riid As OLEGuids.OLECLSID, ByRef pdwSupportedOptions As Long, ByRef pdwEnabledOptions As Long)
Const INTERFACESAFE_FOR_UNTRUSTED_CALLER As Long = &H1, INTERFACESAFE_FOR_UNTRUSTED_DATA As Long = &H2
pdwSupportedOptions = INTERFACESAFE_FOR_UNTRUSTED_CALLER Or INTERFACESAFE_FOR_UNTRUSTED_DATA
pdwEnabledOptions = INTERFACESAFE_FOR_UNTRUSTED_CALLER Or INTERFACESAFE_FOR_UNTRUSTED_DATA
End Sub
Private Sub IObjectSafety_SetInterfaceSafetyOptions(ByRef riid As OLEGuids.OLECLSID, ByVal dwOptionsSetMask As Long, ByVal dwEnabledOptions As Long)
End Sub
Private Sub IOleInPlaceActiveObjectVB_TranslateAccelerator(ByRef Handled As Boolean, ByRef RetVal As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal Shift As Long)
If wMsg = WM_KEYDOWN Or wMsg = WM_KEYUP Then
Dim KeyCode As Integer, IsInputKey As Boolean
KeyCode = wParam And &HFF&
If wMsg = WM_KEYDOWN Then
RaiseEvent PreviewKeyDown(KeyCode, IsInputKey)
ElseIf wMsg = WM_KEYUP Then
RaiseEvent PreviewKeyUp(KeyCode, IsInputKey)
End If
Select Case KeyCode
Case vbKeyUp, vbKeyDown, vbKeyLeft, vbKeyRight, vbKeyPageDown, vbKeyPageUp, vbKeyHome, vbKeyEnd
If TextBoxHandle <> 0 Then
SendMessage TextBoxHandle, wMsg, wParam, ByVal lParam
Handled = True
End If
Case vbKeyTab, vbKeyReturn, vbKeyEscape
If IsInputKey = True Then
If TextBoxHandle <> 0 Then
SendMessage TextBoxHandle, wMsg, wParam, ByVal lParam
Handled = True
End If
End If
End Select
End If
End Sub
Private Sub IOleControlVB_GetControlInfo(ByRef Handled As Boolean, ByRef AccelCount As Integer, ByRef AccelTable As Long, ByRef Flags As Long)
If PropWantReturn = True And PropMultiLine = True Then
Flags = CTRLINFO_EATS_RETURN
Handled = True
End If
End Sub
Private Sub IOleControlVB_OnMnemonic(ByRef Handled As Boolean, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal Shift As Long)
End Sub
Private Sub IPerPropertyBrowsingVB_GetDisplayString(ByRef Handled As Boolean, ByVal DispID As Long, ByRef DisplayName As String)
If DispID = DispIDMousePointer Then
Call ComCtlsIPPBSetDisplayStringMousePointer(PropMousePointer, DisplayName)
Handled = True
End If
End Sub
Private Sub IPerPropertyBrowsingVB_GetPredefinedStrings(ByRef Handled As Boolean, ByVal DispID As Long, ByRef StringsOut() As String, ByRef CookiesOut() As Long)
If DispID = DispIDMousePointer Then
Call ComCtlsIPPBSetPredefinedStringsMousePointer(StringsOut(), CookiesOut())
Handled = True
End If
End Sub
Private Sub IPerPropertyBrowsingVB_GetPredefinedValue(ByRef Handled As Boolean, ByVal DispID As Long, ByVal Cookie As Long, ByRef Value As Variant)
If DispID = DispIDMousePointer Then
Value = Cookie
Handled = True
End If
End Sub
Private Sub UserControl_Initialize()
Call ComCtlsLoadShellMod
Call ComCtlsInitCC(ICC_STANDARD_CLASSES)
Call SetVTableSubclass(Me, VTableInterfaceInPlaceActiveObject)
Call SetVTableSubclass(Me, VTableInterfaceControl)
Call SetVTableSubclass(Me, VTableInterfacePerPropertyBrowsing)
End Sub
Private Sub UserControl_InitProperties()
If DispIDMousePointer = 0 Then DispIDMousePointer = GetDispID(Me, "MousePointer")
On Error Resume Next
TextBoxDesignMode = Not Ambient.UserMode
TextBoxTopDesignMode = Not GetTopUserControl(Me).Ambient.UserMode
On Error GoTo 0
Set PropFont = Ambient.Font
PropVisualStyles = True
PropOLEDragMode = vbOLEDragManual
PropOLEDragDropScroll = True
PropOLEDropMode = vbOLEDropNone
PropMousePointer = 0: Set PropMouseIcon = Nothing
PropMouseTrack = False
PropRightToLeft = Ambient.RightToLeft
PropRightToLeftMode = CCRightToLeftModeVBAME
If PropRightToLeft = True Then Me.RightToLeft = True
PropBorderStyle = CCBorderStyleSunken
PropText = Ambient.DisplayName
If PropRightToLeft = False Then PropAlignment = vbLeftJustify Else PropAlignment = vbRightJustify
PropAllowOnlyNumbers = False
PropLocked = False
PropHideSelection = True
PropPasswordChar = 0
PropUseSystemPasswordChar = False
PropMultiLine = False
PropMaxLength = 0
PropScrollBars = vbSBNone
PropCueBanner = vbNullString
PropCharacterCasing = TxtCharacterCasingNormal
PropWantReturn = False
PropIMEMode = CCIMEModeNoControl
PropNetAddressValidator = False
PropNetAddressType = TxtNetAddressTypeNone
PropAllowOverType = False
PropOverTypeMode = False
Call CreateTextBox
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
If DispIDMousePointer = 0 Then DispIDMousePointer = GetDispID(Me, "MousePointer")
On Error Resume Next
TextBoxDesignMode = Not Ambient.UserMode
TextBoxTopDesignMode = Not GetTopUserControl(Me).Ambient.UserMode
On Error GoTo 0
With PropBag
Set PropFont = .ReadProperty("Font", Nothing)
PropVisualStyles = .ReadProperty("VisualStyles", True)
Me.BackColor = .ReadProperty("BackColor", vbWindowBackground)
Me.ForeColor = .ReadProperty("ForeColor", vbWindowText)
Me.Enabled = .ReadProperty("Enabled", True)
PropOLEDragMode = .ReadProperty("OLEDragMode", vbOLEDragManual)
PropOLEDragDropScroll = .ReadProperty("OLEDragDropScroll", True)
Me.OLEDropMode = .ReadProperty("OLEDropMode", vbOLEDropNone)
PropMousePointer = .ReadProperty("MousePointer", 0)
Set PropMouseIcon = .ReadProperty("MouseIcon", Nothing)
PropMouseTrack = .ReadProperty("MouseTrack", False)
PropRightToLeft = .ReadProperty("RightToLeft", False)
PropRightToLeftMode = .ReadProperty("RightToLeftMode", CCRightToLeftModeVBAME)
If PropRightToLeft = True Then Me.RightToLeft = True
PropBorderStyle = .ReadProperty("BorderStyle", CCBorderStyleSunken)
PropText = VarToStr(.ReadProperty("Text", vbNullString))
PropAlignment = .ReadProperty("Alignment", vbLeftJustify)
PropAllowOnlyNumbers = .ReadProperty("AllowOnlyNumbers", False)
PropLocked = .ReadProperty("Locked", False)
PropHideSelection = .ReadProperty("HideSelection", True)
PropPasswordChar = .ReadProperty("PasswordChar", 0)
PropUseSystemPasswordChar = .ReadProperty("UseSystemPasswordChar", False)
PropMultiLine = .ReadProperty("MultiLine", False)
PropMaxLength = .ReadProperty("MaxLength", 0)
PropScrollBars = .ReadProperty("ScrollBars", vbSBNone)
PropCueBanner = VarToStr(.ReadProperty("CueBanner", vbNullString))
PropCharacterCasing = .ReadProperty("CharacterCasing", TxtCharacterCasingNormal)
PropWantReturn = .ReadProperty("WantReturn", False)
PropIMEMode = .ReadProperty("IMEMode", CCIMEModeNoControl)
PropNetAddressValidator = .ReadProperty("NetAddressValidator", False)
PropNetAddressType = .ReadProperty("NetAddressType", TxtNetAddressTypeNone)
PropAllowOverType = .ReadProperty("AllowOverType", False)
PropOverTypeMode = .ReadProperty("OverTypeMode", False)
End With
Call CreateTextBox
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
With PropBag
.WriteProperty "Font", IIf(OLEFontIsEqual(PropFont, Ambient.Font) = False, PropFont, Nothing), Nothing
.WriteProperty "VisualStyles", PropVisualStyles, True
.WriteProperty "BackColor", Me.BackColor, vbWindowBackground
.WriteProperty "ForeColor", Me.ForeColor, vbWindowText
.WriteProperty "Enabled", Me.Enabled, True
.WriteProperty "OLEDragMode", PropOLEDragMode, vbOLEDragManual
.WriteProperty "OLEDragDropScroll", PropOLEDragDropScroll, True
.WriteProperty "OLEDropMode", PropOLEDropMode, vbOLEDropNone
.WriteProperty "MousePointer", PropMousePointer, 0
.WriteProperty "MouseIcon", PropMouseIcon, Nothing
.WriteProperty "MouseTrack", PropMouseTrack, False
.WriteProperty "RightToLeft", PropRightToLeft, False
.WriteProperty "RightToLeftMode", PropRightToLeftMode, CCRightToLeftModeVBAME
.WriteProperty "BorderStyle", PropBorderStyle, CCBorderStyleSunken
.WriteProperty "Text", StrToVar(PropText), vbNullString
.WriteProperty "Alignment", PropAlignment, vbLeftJustify
.WriteProperty "AllowOnlyNumbers", PropAllowOnlyNumbers, False
.WriteProperty "Locked", PropLocked, False
.WriteProperty "HideSelection", PropHideSelection, True
.WriteProperty "PasswordChar", PropPasswordChar, 0
.WriteProperty "UseSystemPasswordChar", PropUseSystemPasswordChar, False
.WriteProperty "MultiLine", PropMultiLine, False
.WriteProperty "MaxLength", PropMaxLength, 0
.WriteProperty "ScrollBars", PropScrollBars, vbSBNone
.WriteProperty "CueBanner", StrToVar(PropCueBanner), vbNullString
.WriteProperty "CharacterCasing", PropCharacterCasing, TxtCharacterCasingNormal
.WriteProperty "WantReturn", PropWantReturn, False
.WriteProperty "IMEMode", PropIMEMode, CCIMEModeNoControl
.WriteProperty "NetAddressValidator", PropNetAddressValidator, False
.WriteProperty "NetAddressType", PropNetAddressType, TxtNetAddressTypeNone
.WriteProperty "AllowOverType", PropAllowOverType, False
.WriteProperty "OverTypeMode", PropOverTypeMode, False
End With
End Sub
Private Sub UserControl_OLECompleteDrag(Effect As Long)
If PropOLEDragMode = vbOLEDragAutomatic And TextBoxAutoDragIsActive = True And Effect = vbDropEffectMove Then
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, WM_CLEAR, 0, ByVal 0&
End If
RaiseEvent OLECompleteDrag(Effect)
TextBoxAutoDragIsActive = False
End Sub
Private Sub UserControl_OLEDragDrop(data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent OLEDragDrop(data, Effect, Button, Shift, UserControl.ScaleX(X, vbPixels, vbContainerPosition), UserControl.ScaleY(Y, vbPixels, vbContainerPosition))
If PropOLEDropMode = vbOLEDropAutomatic And TextBoxHandle <> 0 Then
If Not Effect = vbDropEffectNone Then
Me.Refresh
Dim Text As String
If data.GetFormat(CF_UNICODETEXT) = True Then
Text = data.GetData(CF_UNICODETEXT)
Text = Left$(Text, InStr(Text, vbNullChar) - 1)
ElseIf data.GetFormat(vbCFText) = True Then
Text = data.GetData(vbCFText)
End If
If Not Text = vbNullString Then
Dim CharPos As Long
CharPos = CIntToUInt(LoWord(SendMessage(TextBoxHandle, EM_CHARFROMPOS, 0, ByVal MakeDWord(X, Y))))
If TextBoxAutoDragIsActive = True Then
TextBoxAutoDragIsActive = False
Dim SelStart As Long, SelEnd As Long
SendMessage TextBoxHandle, EM_GETSEL, VarPtr(SelStart), ByVal VarPtr(SelEnd)
If CharPos >= SelStart And CharPos <= SelEnd Then
Effect = vbDropEffectNone
Exit Sub
End If
If SelStart < CharPos Then CharPos = CharPos - (SelEnd - SelStart)
If Effect = vbDropEffectMove Then SendMessage TextBoxHandle, WM_CLEAR, 0, ByVal 0&
Else
If GetFocus() <> TextBoxHandle Then SetFocusAPI UserControl.hwnd
End If
SendMessage TextBoxHandle, EM_SETSEL, CharPos, ByVal CharPos
SendMessage TextBoxHandle, EM_REPLACESEL, 1, ByVal StrPtr(Text)
SendMessage TextBoxHandle, EM_SETSEL, CharPos, ByVal (CharPos + Len(Text))
End If
End If
End If
End Sub
Private Sub UserControl_OLEDragOver(data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
RaiseEvent OLEDragOver(data, Effect, Button, Shift, UserControl.ScaleX(X, vbPixels, vbContainerPosition), UserControl.ScaleY(Y, vbPixels, vbContainerPosition), State)
If TextBoxHandle <> 0 Then
If State = vbOver And Not Effect = vbDropEffectNone Then
If PropOLEDragDropScroll = True Then
Dim RC As RECT
GetWindowRect TextBoxHandle, RC
Dim dwStyle As Long
dwStyle = GetWindowLong(TextBoxHandle, GWL_STYLE)
If (dwStyle And WS_HSCROLL) = WS_HSCROLL Then
If Abs(X) < (16 * PixelsPerDIP_X()) Then
SendMessage TextBoxHandle, WM_HSCROLL, SB_LINELEFT, ByVal 0&
ElseIf Abs(X - (RC.Right - RC.Left)) < (16 * PixelsPerDIP_X()) Then
SendMessage TextBoxHandle, WM_HSCROLL, SB_LINERIGHT, ByVal 0&
End If
End If
If (dwStyle And WS_VSCROLL) = WS_VSCROLL Then
If Abs(Y) < (16 * PixelsPerDIP_Y()) Then
SendMessage TextBoxHandle, WM_VSCROLL, SB_LINEUP, ByVal 0&
ElseIf Abs(Y - (RC.Bottom - RC.Top)) < (16 * PixelsPerDIP_Y()) Then
SendMessage TextBoxHandle, WM_VSCROLL, SB_LINEDOWN, ByVal 0&
End If
End If
End If
End If
If PropOLEDropMode = vbOLEDropAutomatic Then
If State = vbOver And Not Effect = vbDropEffectNone Then
Dim CharPos As Long, CaretPos As Long
CharPos = CIntToUInt(LoWord(SendMessage(TextBoxHandle, EM_CHARFROMPOS, 0, ByVal MakeDWord(X, Y))))
CaretPos = SendMessage(TextBoxHandle, EM_POSFROMCHAR, CharPos, ByVal 0&)
If CaretPos > -1 Then
Dim hDC As Long, Size As SIZEAPI
hDC = GetDC(TextBoxHandle)
SelectObject hDC, TextBoxFontHandle
GetTextExtentPoint32 hDC, StrPtr("|"), 1, Size
ReleaseDC TextBoxHandle, hDC
CreateCaret TextBoxHandle, 0, 0, Size.cy
SetCaretPos LoWord(CaretPos), HiWord(CaretPos)
ShowCaret TextBoxHandle
Else
If GetFocus() <> TextBoxHandle Then
DestroyCaret
Else
Me.Refresh
End If
End If
ElseIf State = vbLeave Then
If GetFocus() <> TextBoxHandle Then
DestroyCaret
Else
Me.Refresh
End If
End If
End If
End If
End Sub
Private Sub UserControl_OLEGiveFeedback(Effect As Long, DefaultCursors As Boolean)
RaiseEvent OLEGiveFeedback(Effect, DefaultCursors)
End Sub
Private Sub UserControl_OLESetData(data As DataObject, DataFormat As Integer)
RaiseEvent OLESetData(data, DataFormat)
End Sub
Private Sub UserControl_OLEStartDrag(data As DataObject, AllowedEffects As Long)
If PropOLEDragMode = vbOLEDragAutomatic Then
Dim Text As String
Text = Me.SelText
data.SetData StrToVar(Text & vbNullChar), CF_UNICODETEXT
data.SetData StrToVar(Text), vbCFText
AllowedEffects = vbDropEffectMove
TextBoxAutoDragIsActive = True
End If
RaiseEvent OLEStartDrag(data, AllowedEffects)
If AllowedEffects = vbDropEffectNone Then TextBoxAutoDragIsActive = False
End Sub
Public Sub OLEDrag()
UserControl.OLEDrag
End Sub
Private Sub UserControl_Resize()
Static InProc As Boolean
If InProc = True Then Exit Sub
InProc = True
With UserControl
If DPICorrectionFactor() <> 1 Then Call SyncObjectRectsToContainer(Me)
If TextBoxHandle <> 0 Then MoveWindow TextBoxHandle, 0, 0, .ScaleWidth, .ScaleHeight, 1
End With
InProc = False
End Sub
Private Sub UserControl_Terminate()
Call RemoveVTableSubclass(Me, VTableInterfaceInPlaceActiveObject)
Call RemoveVTableSubclass(Me, VTableInterfaceControl)
Call RemoveVTableSubclass(Me, VTableInterfacePerPropertyBrowsing)
Call DestroyTextBox
Call ComCtlsReleaseShellMod
End Sub
Public Property Get Name() As String
Name = Ambient.DisplayName
End Property
Public Property Get Tag() As String
Tag = Extender.Tag
End Property
Public Property Let Tag(ByVal Value As String)
Extender.Tag = Value
End Property
Public Property Get Parent() As Object
Set Parent = UserControl.Parent
End Property
Public Property Get Container() As Object
Set Container = Extender.Container
End Property
Public Property Set Container(ByVal Value As Object)
Set Extender.Container = Value
End Property
Public Property Get Left() As Single
Left = Extender.Left
End Property
Public Property Let Left(ByVal Value As Single)
Extender.Left = Value
End Property
Public Property Get Top() As Single
Top = Extender.Top
End Property
Public Property Let Top(ByVal Value As Single)
Extender.Top = Value
End Property
Public Property Get Width() As Single
Width = Extender.Width
End Property
Public Property Let Width(ByVal Value As Single)
Extender.Width = Value
End Property
Public Property Get Height() As Single
Height = Extender.Height
End Property
Public Property Let Height(ByVal Value As Single)
Extender.Height = Value
End Property
Public Property Get Visible() As Boolean
Visible = Extender.Visible
End Property
Public Property Let Visible(ByVal Value As Boolean)
Extender.Visible = Value
End Property
Public Property Get ToolTipText() As String
ToolTipText = Extender.ToolTipText
End Property
Public Property Let ToolTipText(ByVal Value As String)
Extender.ToolTipText = Value
End Property
Public Property Get HelpContextID() As Long
HelpContextID = Extender.HelpContextID
End Property
Public Property Let HelpContextID(ByVal Value As Long)
Extender.HelpContextID = Value
End Property
Public Property Get WhatsThisHelpID() As Long
WhatsThisHelpID = Extender.WhatsThisHelpID
End Property
Public Property Let WhatsThisHelpID(ByVal Value As Long)
Extender.WhatsThisHelpID = Value
End Property
Public Property Get DragIcon() As IPictureDisp
Set DragIcon = Extender.DragIcon
End Property
Public Property Let DragIcon(ByVal Value As IPictureDisp)
Extender.DragIcon = Value
End Property
Public Property Set DragIcon(ByVal Value As IPictureDisp)
Set Extender.DragIcon = Value
End Property
Public Property Get DragMode() As Integer
DragMode = Extender.DragMode
End Property
Public Property Let DragMode(ByVal Value As Integer)
Extender.DragMode = Value
End Property
Public Sub Drag(Optional ByRef Action As Variant)
If IsMissing(Action) Then Extender.Drag Else Extender.Drag Action
End Sub
Public Sub SetFocus()
Extender.SetFocus
End Sub
Public Sub ZOrder(Optional ByRef Position As Variant)
If IsMissing(Position) Then Extender.ZOrder Else Extender.ZOrder Position
End Sub
Public Property Get hwnd() As Long
hwnd = TextBoxHandle
End Property
Public Property Get hWndUserControl() As Long
hWndUserControl = UserControl.hwnd
End Property
Public Property Get Font() As StdFont
Set Font = PropFont
End Property
Public Property Let Font(ByVal NewFont As StdFont)
Set Me.Font = NewFont
End Property
Public Property Set Font(ByVal NewFont As StdFont)
If NewFont Is Nothing Then Set NewFont = Ambient.Font
Dim OldFontHandle As Long
Set PropFont = NewFont
OldFontHandle = TextBoxFontHandle
TextBoxFontHandle = CreateGDIFontFromOLEFont(PropFont)
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, WM_SETFONT, TextBoxFontHandle, ByVal 1&
If OldFontHandle <> 0 Then DeleteObject OldFontHandle
UserControl.PropertyChanged "Font"
End Property
Private Sub PropFont_FontChanged(ByVal PropertyName As String)
Dim OldFontHandle As Long
OldFontHandle = TextBoxFontHandle
TextBoxFontHandle = CreateGDIFontFromOLEFont(PropFont)
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, WM_SETFONT, TextBoxFontHandle, ByVal 1&
If OldFontHandle <> 0 Then DeleteObject OldFontHandle
UserControl.PropertyChanged "Font"
End Sub
Public Property Get VisualStyles() As Boolean
VisualStyles = PropVisualStyles
End Property
Public Property Let VisualStyles(ByVal Value As Boolean)
PropVisualStyles = Value
If TextBoxHandle <> 0 And EnabledVisualStyles() = True Then
If PropVisualStyles = True Then
ActivateVisualStyles TextBoxHandle
Else
RemoveVisualStyles TextBoxHandle
End If
Me.Refresh
End If
UserControl.PropertyChanged "VisualStyles"
End Property
Public Property Get BackColor() As OLE_COLOR
BackColor = UserControl.BackColor
End Property
Public Property Let BackColor(ByVal Value As OLE_COLOR)
UserControl.BackColor = Value
Me.Refresh
UserControl.PropertyChanged "BackColor"
End Property
Public Property Get ForeColor() As OLE_COLOR
ForeColor = UserControl.ForeColor
End Property
Public Property Let ForeColor(ByVal Value As OLE_COLOR)
UserControl.ForeColor = Value
Me.Refresh
UserControl.PropertyChanged "ForeColor"
End Property
Public Property Get Enabled() As Boolean
Enabled = UserControl.Enabled
End Property
Public Property Let Enabled(ByVal Value As Boolean)
UserControl.Enabled = Value
If TextBoxHandle <> 0 Then EnableWindow TextBoxHandle, IIf(Value = True, 1, 0)
UserControl.PropertyChanged "Enabled"
End Property
Public Property Get OLEDragMode() As VBRUN.OLEDragConstants
OLEDragMode = PropOLEDragMode
End Property
Public Property Let OLEDragMode(ByVal Value As VBRUN.OLEDragConstants)
Select Case Value
Case vbOLEDragManual, vbOLEDragAutomatic
PropOLEDragMode = Value
Case Else
ERR.Raise 380
End Select
UserControl.PropertyChanged "OLEDragMode"
End Property
Public Property Get OLEDragDropScroll() As Boolean
OLEDragDropScroll = PropOLEDragDropScroll
End Property
Public Property Let OLEDragDropScroll(ByVal Value As Boolean)
PropOLEDragDropScroll = Value
UserControl.PropertyChanged "OLEDragDropScroll"
End Property
Public Property Get OLEDropMode() As VBRUN.OLEDropConstants
OLEDropMode = PropOLEDropMode
End Property
Public Property Let OLEDropMode(ByVal Value As VBRUN.OLEDropConstants)
Select Case Value
Case vbOLEDropNone, vbOLEDropManual, vbOLEDropAutomatic
PropOLEDropMode = Value
UserControl.OLEDropMode = IIf(PropOLEDropMode = vbOLEDropAutomatic, vbOLEDropManual, Value)
Case Else
ERR.Raise 380
End Select
UserControl.PropertyChanged "OLEDropMode"
End Property
Public Property Get MousePointer() As Integer
MousePointer = PropMousePointer
End Property
Public Property Let MousePointer(ByVal Value As Integer)
Select Case Value
Case 0 To 16, 99
PropMousePointer = Value
Case Else
ERR.Raise 380
End Select
UserControl.PropertyChanged "MousePointer"
End Property
Public Property Get MouseIcon() As IPictureDisp
Set MouseIcon = PropMouseIcon
End Property
Public Property Let MouseIcon(ByVal Value As IPictureDisp)
Set Me.MouseIcon = Value
End Property
Public Property Set MouseIcon(ByVal Value As IPictureDisp)
If Value Is Nothing Then
Set PropMouseIcon = Nothing
Else
If Value.Type = vbPicTypeIcon Or Value.Handle = 0 Then
Set PropMouseIcon = Value
Else
If TextBoxDesignMode = True Then
MsgBox "Invalid property value", vbCritical + vbOKOnly
Exit Property
Else
ERR.Raise 380
End If
End If
End If
UserControl.PropertyChanged "MouseIcon"
End Property
Public Property Get MouseTrack() As Boolean
MouseTrack = PropMouseTrack
End Property
Public Property Let MouseTrack(ByVal Value As Boolean)
PropMouseTrack = Value
UserControl.PropertyChanged "MouseTrack"
End Property
Public Property Get RightToLeft() As Boolean
RightToLeft = PropRightToLeft
End Property
Public Property Let RightToLeft(ByVal Value As Boolean)
PropRightToLeft = Value
UserControl.RightToLeft = PropRightToLeft
Call ComCtlsCheckRightToLeft(PropRightToLeft, UserControl.RightToLeft, PropRightToLeftMode)
Dim dwMask As Long
If PropRightToLeft = True Then dwMask = WS_EX_RTLREADING Or WS_EX_LEFTSCROLLBAR
If TextBoxHandle <> 0 Then Call ComCtlsSetRightToLeft(TextBoxHandle, dwMask)
UserControl.PropertyChanged "RightToLeft"
End Property
Public Property Get RightToLeftMode() As CCRightToLeftModeConstants
RightToLeftMode = PropRightToLeftMode
End Property
Public Property Let RightToLeftMode(ByVal Value As CCRightToLeftModeConstants)
Select Case Value
Case CCRightToLeftModeNoControl, CCRightToLeftModeVBAME, CCRightToLeftModeSystemLocale, CCRightToLeftModeUserLocale, CCRightToLeftModeOSLanguage
PropRightToLeftMode = Value
Case Else
ERR.Raise 380
End Select
Me.RightToLeft = PropRightToLeft
UserControl.PropertyChanged "RightToLeftMode"
End Property
Public Property Get BorderStyle() As CCBorderStyleConstants
BorderStyle = PropBorderStyle
End Property
Public Property Let BorderStyle(ByVal Value As CCBorderStyleConstants)
Select Case Value
Case CCBorderStyleNone, CCBorderStyleSingle, CCBorderStyleThin, CCBorderStyleSunken, CCBorderStyleRaised
PropBorderStyle = Value
Case Else
ERR.Raise 380
End Select
If TextBoxHandle <> 0 Then Call ComCtlsChangeBorderStyle(TextBoxHandle, PropBorderStyle)
UserControl.PropertyChanged "BorderStyle"
End Property
Public Property Get Text() As String
If TextBoxHandle <> 0 Then
Text = String(SendMessage(TextBoxHandle, WM_GETTEXTLENGTH, 0, ByVal 0&), vbNullChar)
SendMessage TextBoxHandle, WM_GETTEXT, Len(Text) + 1, ByVal StrPtr(Text)
Else
Text = PropText
End If
End Property
Public Property Let Text(ByVal Value As String)
If PropMaxLength > 0 Then Value = Left$(Value, PropMaxLength)
Dim Changed As Boolean
Changed = CBool(Me.Text <> Value)
PropText = Value
If TextBoxHandle <> 0 Then
TextBoxChangeFrozen = True
SendMessage TextBoxHandle, WM_SETTEXT, 0, ByVal StrPtr(PropText)
TextBoxChangeFrozen = False
End If
UserControl.PropertyChanged "Text"
If Changed = True Then
On Error Resume Next
UserControl.Extender.DataChanged = True
On Error GoTo 0
RaiseEvent Change
End If
End Property
Public Property Get Default() As String
Default = Me.Text
End Property
Public Property Let Default(ByVal Value As String)
Me.Text = Value
End Property
Public Property Get Alignment() As VBRUN.AlignmentConstants
Alignment = PropAlignment
End Property
Public Property Let Alignment(ByVal Value As VBRUN.AlignmentConstants)
Select Case Value
Case vbLeftJustify, vbCenter, vbRightJustify
PropAlignment = Value
Case Else
ERR.Raise 380
End Select
If TextBoxHandle <> 0 Then
Dim dwStyle As Long
dwStyle = GetWindowLong(TextBoxHandle, GWL_STYLE)
If (dwStyle And ES_LEFT) = ES_LEFT Then dwStyle = dwStyle And Not ES_LEFT
If (dwStyle And ES_CENTER) = ES_CENTER Then dwStyle = dwStyle And Not ES_CENTER
If (dwStyle And ES_RIGHT) = ES_RIGHT Then dwStyle = dwStyle And Not ES_RIGHT
Select Case PropAlignment
Case vbLeftJustify
dwStyle = dwStyle Or ES_LEFT
Case vbCenter
dwStyle = dwStyle Or ES_CENTER
Case vbRightJustify
dwStyle = dwStyle Or ES_RIGHT
End Select
SetWindowLong TextBoxHandle, GWL_STYLE, dwStyle
Me.Refresh
End If
UserControl.PropertyChanged "Alignment"
End Property
Public Property Get AllowOnlyNumbers() As Boolean
AllowOnlyNumbers = PropAllowOnlyNumbers
End Property
Public Property Let AllowOnlyNumbers(ByVal Value As Boolean)
PropAllowOnlyNumbers = Value
If TextBoxHandle <> 0 Then
Dim dwStyle As Long
dwStyle = GetWindowLong(TextBoxHandle, GWL_STYLE)
If PropAllowOnlyNumbers = True Then
If Not (dwStyle And ES_NUMBER) = ES_NUMBER Then dwStyle = dwStyle Or ES_NUMBER
Else
If (dwStyle And ES_NUMBER) = ES_NUMBER Then dwStyle = dwStyle And Not ES_NUMBER
End If
SetWindowLong TextBoxHandle, GWL_STYLE, dwStyle
End If
UserControl.PropertyChanged "AllowOnlyNumbers"
End Property
Public Property Get Locked() As Boolean
If TextBoxHandle <> 0 Then
Locked = CBool((GetWindowLong(TextBoxHandle, GWL_STYLE) And ES_READONLY) <> 0)
Else
Locked = PropLocked
End If
End Property
Public Property Let Locked(ByVal Value As Boolean)
PropLocked = Value
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_SETREADONLY, IIf(PropLocked = True, 1, 0), ByVal 0&
UserControl.PropertyChanged "Locked"
End Property
Public Property Get HideSelection() As Boolean
HideSelection = PropHideSelection
End Property
Public Property Let HideSelection(ByVal Value As Boolean)
PropHideSelection = Value
If TextBoxHandle <> 0 Then Call ReCreateTextBox
UserControl.PropertyChanged "HideSelection"
End Property
Public Property Get PasswordChar() As String
If TextBoxHandle <> 0 Then
PasswordChar = ChrW(SendMessage(TextBoxHandle, EM_GETPASSWORDCHAR, 0, ByVal 0&))
Else
PasswordChar = ChrW(PropPasswordChar)
End If
End Property
Public Property Let PasswordChar(ByVal Value As String)
If PropUseSystemPasswordChar = True Then Exit Property
If Value = vbNullString Or Len(Value) = 0 Then
PropPasswordChar = 0
ElseIf Len(Value) = 1 Then
PropPasswordChar = AscW(Value)
Else
If TextBoxDesignMode = True Then
MsgBox "Invalid property value", vbCritical + vbOKOnly
Exit Property
Else
ERR.Raise 380
End If
End If
If TextBoxHandle <> 0 Then
SendMessage TextBoxHandle, EM_SETPASSWORDCHAR, PropPasswordChar, ByVal 0&
Me.Refresh
End If
UserControl.PropertyChanged "PasswordChar"
End Property
Public Property Get UseSystemPasswordChar() As Boolean
UseSystemPasswordChar = PropUseSystemPasswordChar
End Property
Public Property Let UseSystemPasswordChar(ByVal Value As Boolean)
PropUseSystemPasswordChar = Value
If TextBoxHandle <> 0 Then Call ReCreateTextBox
UserControl.PropertyChanged "UseSystemPasswordChar"
End Property
Public Property Get MultiLine() As Boolean
MultiLine = PropMultiLine
End Property
Public Property Let MultiLine(ByVal Value As Boolean)
PropMultiLine = Value
If TextBoxHandle <> 0 Then Call ReCreateTextBox
UserControl.PropertyChanged "MultiLine"
End Property
Public Property Get MaxLength() As Long
MaxLength = PropMaxLength
End Property
Public Property Let MaxLength(ByVal Value As Long)
If Value < 0 Then
If TextBoxDesignMode = True Then
MsgBox "Invalid property value", vbCritical + vbOKOnly
Exit Property
Else
ERR.Raise 380
End If
End If
PropMaxLength = Value
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_SETLIMITTEXT, PropMaxLength, ByVal 0&
UserControl.PropertyChanged "MaxLength"
End Property
Public Property Get ScrollBars() As VBRUN.ScrollBarConstants
ScrollBars = PropScrollBars
End Property
Public Property Let ScrollBars(ByVal Value As VBRUN.ScrollBarConstants)
Select Case Value
Case vbSBNone, vbHorizontal, vbVertical, vbBoth
PropScrollBars = Value
If TextBoxHandle <> 0 Then Call ReCreateTextBox
Case Else
ERR.Raise 380
End Select
UserControl.PropertyChanged "ScrollBars"
End Property
Public Property Get CueBanner() As String
CueBanner = PropCueBanner
End Property
Public Property Let CueBanner(ByVal Value As String)
PropCueBanner = Value
If TextBoxHandle <> 0 And PropMultiLine = False And ComCtlsSupportLevel() >= 1 Then SendMessage TextBoxHandle, EM_SETCUEBANNER, 0, ByVal StrPtr(PropCueBanner)
UserControl.PropertyChanged "CueBanner"
End Property
Public Property Get CharacterCasing() As TxtCharacterCasingConstants
CharacterCasing = PropCharacterCasing
End Property
Public Property Let CharacterCasing(ByVal Value As TxtCharacterCasingConstants)
Select Case Value
Case TxtCharacterCasingNormal, TxtCharacterCasingUpper, TxtCharacterCasingLower
PropCharacterCasing = Value
Case Else
ERR.Raise 380
End Select
If TextBoxHandle <> 0 Then
Dim dwStyle As Long
dwStyle = GetWindowLong(TextBoxHandle, GWL_STYLE)
If (dwStyle And ES_UPPERCASE) = ES_UPPERCASE Then dwStyle = dwStyle And Not ES_UPPERCASE
If (dwStyle And ES_LOWERCASE) = ES_LOWERCASE Then dwStyle = dwStyle And Not ES_LOWERCASE
Select Case PropCharacterCasing
Case TxtCharacterCasingUpper
dwStyle = dwStyle Or ES_UPPERCASE
Case TxtCharacterCasingLower
dwStyle = dwStyle Or ES_LOWERCASE
End Select
SetWindowLong TextBoxHandle, GWL_STYLE, dwStyle
If TextBoxDesignMode = True Then
SendMessage TextBoxHandle, WM_SETTEXT, 0, ByVal 0&
SendMessage TextBoxHandle, WM_SETTEXT, 0, ByVal StrPtr(PropText)
End If
End If
UserControl.PropertyChanged "CharacterCasing"
End Property
Public Property Get WantReturn() As Boolean
WantReturn = PropWantReturn
End Property
Public Property Let WantReturn(ByVal Value As Boolean)
If PropWantReturn = Value Then Exit Property
PropWantReturn = Value
If TextBoxHandle <> 0 And TextBoxDesignMode = False Then
' It is not possible (in VB6) to achieve this when specifying ES_WANTRETURN.
Call OnControlInfoChanged(Me, CBool(GetFocus() = TextBoxHandle))
End If
UserControl.PropertyChanged "WantReturn"
End Property
Public Property Get IMEMode() As CCIMEModeConstants
IMEMode = PropIMEMode
End Property
Public Property Let IMEMode(ByVal Value As CCIMEModeConstants)
Select Case Value
Case CCIMEModeNoControl, CCIMEModeOn, CCIMEModeOff, CCIMEModeDisable, CCIMEModeHiragana, CCIMEModeKatakana, CCIMEModeKatakanaHalf, CCIMEModeAlphaFull, CCIMEModeAlpha, CCIMEModeHangulFull, CCIMEModeHangul
PropIMEMode = Value
Case Else
ERR.Raise 380
End Select
If TextBoxHandle <> 0 And TextBoxDesignMode = False Then
If GetFocus() = TextBoxHandle Then Call ComCtlsSetIMEMode(TextBoxHandle, TextBoxIMCHandle, PropIMEMode)
End If
UserControl.PropertyChanged "IMEMode"
End Property
Public Property Get NetAddressValidator() As Boolean
NetAddressValidator = PropNetAddressValidator
End Property
Public Property Let NetAddressValidator(ByVal Value As Boolean)
PropNetAddressValidator = Value
If TextBoxHandle <> 0 And ComCtlsSupportLevel() >= 2 Then
TextBoxNetAddressFormat = TxtNetAddressFormatNone
TextBoxNetAddressString = vbNullString
TextBoxNetAddressPortNumber = 0
TextBoxNetAddressPrefixLength = 0
Call ReCreateTextBox
End If
UserControl.PropertyChanged "NetAddressValidator"
End Property
Public Property Get NetAddressType() As TxtNetAddressTypeConstants
NetAddressType = PropNetAddressType
End Property
Public Property Let NetAddressType(ByVal Value As TxtNetAddressTypeConstants)
Select Case Value
Case TxtNetAddressTypeNone, TxtNetAddressTypeIPv4Address, TxtNetAddressTypeIPv4Service, TxtNetAddressTypeIPv4Network, TxtNetAddressTypeIPv6Address, TxtNetAddressTypeIPv6AddressNoScope, TxtNetAddressTypeIPv6Service, TxtNetAddressTypeIPv6ServiceNoScope, TxtNetAddressTypeIPv6Network, TxtNetAddressTypeDNSName, TxtNetAddressTypeDNSService, TxtNetAddressTypeIPAddress, TxtNetAddressTypeIPAddressNoScope, TxtNetAddressTypeIPService, TxtNetAddressTypeIPServiceNoScope, TxtNetAddressTypeIPNetwork, TxtNetAddressTypeAnyAddress, TxtNetAddressTypeAnyAddressNoScope, TxtNetAddressTypeAnyService, TxtNetAddressTypeAnyServiceNoScope
PropNetAddressType = Value
Case Else
ERR.Raise 380
End Select
If TextBoxHandle <> 0 And PropNetAddressValidator = True And ComCtlsSupportLevel() >= 2 Then
Dim AddrMask As Long
Select Case PropNetAddressType
Case TxtNetAddressTypeNone
AddrMask = 0
Case TxtNetAddressTypeIPv4Address
AddrMask = NET_STRING_IPV4_ADDRESS
Case TxtNetAddressTypeIPv4Service
AddrMask = NET_STRING_IPV4_SERVICE
Case TxtNetAddressTypeIPv4Network
AddrMask = NET_STRING_IPV4_NETWORK
Case TxtNetAddressTypeIPv6Address
AddrMask = NET_STRING_IPV6_ADDRESS
Case TxtNetAddressTypeIPv6AddressNoScope
AddrMask = NET_STRING_IPV6_ADDRESS_NO_SCOPE
Case TxtNetAddressTypeIPv6Service
AddrMask = NET_STRING_IPV6_SERVICE
Case TxtNetAddressTypeIPv6ServiceNoScope
AddrMask = NET_STRING_IPV6_SERVICE_NO_SCOPE
Case TxtNetAddressTypeIPv6Network
AddrMask = NET_STRING_IPV6_NETWORK
Case TxtNetAddressTypeDNSName
AddrMask = NET_STRING_NAMED_ADDRESS
Case TxtNetAddressTypeDNSService
AddrMask = NET_STRING_NAMED_SERVICE
Case TxtNetAddressTypeIPAddress
AddrMask = NET_STRING_IP_ADDRESS
Case TxtNetAddressTypeIPAddressNoScope
AddrMask = NET_STRING_IP_ADDRESS_NO_SCOPE
Case TxtNetAddressTypeIPService
AddrMask = NET_STRING_IP_SERVICE
Case TxtNetAddressTypeIPServiceNoScope
AddrMask = NET_STRING_IP_SERVICE_NO_SCOPE
Case TxtNetAddressTypeIPNetwork
AddrMask = NET_STRING_IP_NETWORK
Case TxtNetAddressTypeAnyAddress
AddrMask = NET_STRING_ANY_ADDRESS
Case TxtNetAddressTypeAnyAddressNoScope
AddrMask = NET_STRING_ANY_ADDRESS_NO_SCOPE
Case TxtNetAddressTypeAnyService
AddrMask = NET_STRING_ANY_SERVICE
Case TxtNetAddressTypeAnyServiceNoScope
AddrMask = NET_STRING_ANY_SERVICE_NO_SCOPE
End Select
SendMessage TextBoxHandle, NCM_SETALLOWTYPE, AddrMask, ByVal 0&
End If
UserControl.PropertyChanged "NetAddressType"
End Property
Public Property Get AllowOverType() As Boolean
AllowOverType = PropAllowOverType
End Property
Public Property Let AllowOverType(ByVal Value As Boolean)
PropAllowOverType = Value
If PropAllowOverType = False Then Me.OverTypeMode = False
UserControl.PropertyChanged "AllowOverType"
End Property
Public Property Get OverTypeMode() As Boolean
OverTypeMode = PropOverTypeMode
End Property
Public Property Let OverTypeMode(ByVal Value As Boolean)
If PropOverTypeMode = Value Then Exit Property
If PropAllowOverType = True Then PropOverTypeMode = Value Else PropOverTypeMode = False
UserControl.PropertyChanged "OverTypeMode"
End Property
Private Sub CreateTextBox()
If TextBoxHandle <> 0 Then Exit Sub
Dim dwStyle As Long, dwExStyle As Long
dwStyle = WS_CHILD Or WS_VISIBLE
If PropRightToLeft = True Then dwExStyle = WS_EX_RTLREADING Or WS_EX_LEFTSCROLLBAR
Call ComCtlsInitBorderStyle(dwStyle, dwExStyle, PropBorderStyle)
If PropAllowOnlyNumbers = True Then dwStyle = dwStyle Or ES_NUMBER
If PropRightToLeft = False Then dwStyle = dwStyle Or ES_LEFT Else dwStyle = dwStyle Or ES_RIGHT
If PropLocked = True Then dwStyle = dwStyle Or ES_READONLY
If PropHideSelection = False Then dwStyle = dwStyle Or ES_NOHIDESEL
If PropUseSystemPasswordChar = True Then dwStyle = dwStyle Or ES_PASSWORD
If PropMultiLine = True Then
dwStyle = dwStyle Or ES_MULTILINE
Select Case PropScrollBars
Case vbSBNone
dwStyle = dwStyle Or ES_AUTOVSCROLL
Case vbHorizontal
dwStyle = dwStyle Or WS_HSCROLL Or ES_AUTOVSCROLL Or ES_AUTOHSCROLL
Case vbVertical
dwStyle = dwStyle Or WS_VSCROLL Or ES_AUTOVSCROLL
Case vbBoth
dwStyle = dwStyle Or WS_HSCROLL Or WS_VSCROLL Or ES_AUTOVSCROLL Or ES_AUTOHSCROLL
End Select
Else
dwStyle = dwStyle Or ES_AUTOHSCROLL
End If
Select Case PropCharacterCasing
Case TxtCharacterCasingUpper
dwStyle = dwStyle Or ES_UPPERCASE
Case TxtCharacterCasingLower
dwStyle = dwStyle Or ES_LOWERCASE
End Select
If PropNetAddressValidator = True And ComCtlsSupportLevel() >= 2 Then
If InitNetworkAddressControl() <> 0 Then TextBoxHandle = CreateWindowEx(dwExStyle, StrPtr("msctls_netaddress"), 0, dwStyle, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight, UserControl.hwnd, 0, App.hInstance, ByVal 0&)
End If
If TextBoxHandle = 0 Then TextBoxHandle = CreateWindowEx(dwExStyle, StrPtr("Edit"), 0, dwStyle, 0, 0, UserControl.ScaleWidth, UserControl.ScaleHeight, UserControl.hwnd, 0, App.hInstance, ByVal 0&)
If TextBoxHandle <> 0 Then
If PropPasswordChar <> 0 And PropUseSystemPasswordChar = False Then SendMessage TextBoxHandle, EM_SETPASSWORDCHAR, PropPasswordChar, ByVal 0&
SendMessage TextBoxHandle, EM_SETLIMITTEXT, PropMaxLength, ByVal 0&
SendMessage TextBoxHandle, WM_SETTEXT, 0, ByVal StrPtr(PropText)
End If
Set Me.Font = PropFont
Me.VisualStyles = PropVisualStyles
Me.Enabled = UserControl.Enabled
Me.Alignment = PropAlignment
If Not PropCueBanner = vbNullString Then Me.CueBanner = PropCueBanner
If PropNetAddressValidator = True Then Me.NetAddressType = PropNetAddressType
If TextBoxDesignMode = False Then
If TextBoxHandle <> 0 Then Call ComCtlsSetSubclass(TextBoxHandle, Me, 1)
Call ComCtlsSetSubclass(UserControl.hwnd, Me, 2)
If TextBoxHandle <> 0 Then Call ComCtlsCreateIMC(TextBoxHandle, TextBoxIMCHandle)
End If
End Sub
Private Sub ReCreateTextBox()
If TextBoxDesignMode = False Then
Dim Locked As Boolean
Locked = CBool(LockWindowUpdate(UserControl.hwnd) <> 0)
Dim SelStart As Long, SelEnd As Long
Dim ScrollPosHorz As Integer, ScrollPosVert As Integer
If TextBoxHandle <> 0 Then
SendMessage TextBoxHandle, EM_GETSEL, VarPtr(SelStart), ByVal VarPtr(SelEnd)
If PropMultiLine = True And PropScrollBars <> vbSBNone Then
If PropScrollBars = vbHorizontal Or PropScrollBars = vbBoth Then
ScrollPosHorz = CUIntToInt(GetScrollPos(TextBoxHandle, SB_HORZ) And &HFFFF&)
End If
If PropScrollBars = vbVertical Or PropScrollBars = vbBoth Then
ScrollPosVert = CUIntToInt(GetScrollPos(TextBoxHandle, SB_VERT) And &HFFFF&)
End If
End If
Dim Buffer As String
Buffer = String(SendMessage(TextBoxHandle, WM_GETTEXTLENGTH, 0, ByVal 0&), vbNullChar)
SendMessage TextBoxHandle, WM_GETTEXT, Len(Buffer) + 1, ByVal StrPtr(Buffer)
PropText = Buffer
End If
Call DestroyTextBox
Call CreateTextBox
Call UserControl_Resize
If TextBoxHandle <> 0 Then
SendMessage TextBoxHandle, EM_SETSEL, SelStart, ByVal SelEnd
If ScrollPosHorz > 0 Then SendMessage TextBoxHandle, WM_HSCROLL, MakeDWord(SB_THUMBPOSITION, ScrollPosHorz), ByVal 0&
If ScrollPosVert > 0 Then SendMessage TextBoxHandle, WM_VSCROLL, MakeDWord(SB_THUMBPOSITION, ScrollPosVert), ByVal 0&
End If
If Locked = True Then LockWindowUpdate 0
Me.Refresh
Else
Call DestroyTextBox
Call CreateTextBox
Call UserControl_Resize
End If
End Sub
Private Sub DestroyTextBox()
If TextBoxHandle = 0 Then Exit Sub
Call ComCtlsRemoveSubclass(TextBoxHandle)
Call ComCtlsRemoveSubclass(UserControl.hwnd)
Call ComCtlsDestroyIMC(TextBoxHandle, TextBoxIMCHandle)
ShowWindow TextBoxHandle, SW_HIDE
SetParent TextBoxHandle, 0
DestroyWindow TextBoxHandle
TextBoxHandle = 0
If TextBoxFontHandle <> 0 Then
DeleteObject TextBoxFontHandle
TextBoxFontHandle = 0
End If
End Sub
Public Sub Refresh()
UserControl.Refresh
RedrawWindow UserControl.hwnd, 0, 0, RDW_UPDATENOW Or RDW_INVALIDATE Or RDW_ERASE Or RDW_ALLCHILDREN
End Sub
Public Sub Copy()
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, WM_COPY, 0, ByVal 0&
End Sub
Public Sub Cut()
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, WM_CUT, 0, ByVal 0&
End Sub
Public Sub Paste()
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, WM_PASTE, 0, ByVal 0&
End Sub
Public Sub Clear()
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, WM_CLEAR, 0, ByVal 0&
End Sub
Public Sub Undo()
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_UNDO, 0, ByVal 0&
End Sub
Public Function CanUndo() As Boolean
If TextBoxHandle <> 0 Then CanUndo = CBool(SendMessage(TextBoxHandle, EM_CANUNDO, 0, ByVal 0&) <> 0)
End Function
Public Sub ResetUndoFlag()
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_EMPTYUNDOBUFFER, 0, ByVal 0&
End Sub
Public Property Get Modified() As Boolean
If TextBoxHandle <> 0 Then Modified = CBool(SendMessage(TextBoxHandle, EM_GETMODIFY, 0, ByVal 0&) <> 0)
End Property
Public Property Let Modified(ByVal Value As Boolean)
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_SETMODIFY, IIf(Value = True, 1, 0), ByVal 0&
End Property
Public Property Get SelStart() As Long
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_GETSEL, VarPtr(SelStart), ByVal 0&
End Property
Public Property Let SelStart(ByVal Value As Long)
If TextBoxHandle <> 0 Then
If Value >= 0 Then
SendMessage TextBoxHandle, EM_SETSEL, Value, ByVal Value
Else
ERR.Raise 380
End If
End If
End Property
Public Property Get SelLength() As Long
If TextBoxHandle <> 0 Then
Dim SelStart As Long, SelEnd As Long
SendMessage TextBoxHandle, EM_GETSEL, VarPtr(SelStart), ByVal VarPtr(SelEnd)
SelLength = SelEnd - SelStart
End If
End Property
Public Property Let SelLength(ByVal Value As Long)
If TextBoxHandle <> 0 Then
If Value >= 0 Then
Dim SelStart As Long
SendMessage TextBoxHandle, EM_GETSEL, VarPtr(SelStart), ByVal 0&
SendMessage TextBoxHandle, EM_SETSEL, SelStart, ByVal SelStart + Value
Else
ERR.Raise 380
End If
End If
End Property
Public Property Get SelText() As String
If TextBoxHandle <> 0 Then
Dim SelStart As Long, SelEnd As Long
SendMessage TextBoxHandle, EM_GETSEL, VarPtr(SelStart), ByVal VarPtr(SelEnd)
On Error Resume Next
SelText = Mid$(Me.Text, SelStart + 1, (SelEnd - SelStart))
On Error GoTo 0
End If
End Property
Public Property Let SelText(ByVal Value As String)
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_REPLACESEL, 1, ByVal StrPtr(Value)
End Property
Public Function GetLine(ByVal LineNumber As Long) As String
If LineNumber < 0 Then ERR.Raise 380
If TextBoxHandle <> 0 Then
Dim FirstCharPos As Long, Length As Long
FirstCharPos = SendMessage(TextBoxHandle, EM_LINEINDEX, LineNumber - 1, ByVal 0&)
If FirstCharPos > -1 Then
Length = SendMessage(TextBoxHandle, EM_LINELENGTH, FirstCharPos, ByVal 0&)
If Length > 0 Then
Dim Buffer As String
Buffer = ChrW(Length) & String(Length - 1, vbNullChar)
If LineNumber > 0 Then
If SendMessage(TextBoxHandle, EM_GETLINE, LineNumber - 1, ByVal StrPtr(Buffer)) > 0 Then GetLine = Buffer
Else
If SendMessage(TextBoxHandle, EM_GETLINE, SendMessage(TextBoxHandle, EM_LINEFROMCHAR, FirstCharPos, ByVal 0&), ByVal StrPtr(Buffer)) > 0 Then GetLine = Buffer
End If
End If
Else
ERR.Raise 380
End If
End If
End Function
Public Function GetLineCount() As Long
If TextBoxHandle <> 0 Then GetLineCount = SendMessage(TextBoxHandle, EM_GETLINECOUNT, 0, ByVal 0&)
End Function
Public Sub ScrollToLine(ByVal LineNumber As Long)
If LineNumber < 0 Then ERR.Raise 380
If TextBoxHandle <> 0 Then
If SendMessage(TextBoxHandle, EM_LINEINDEX, LineNumber - 1, ByVal 0&) > -1 Then
Dim LineIndex As Long
LineIndex = SendMessage(TextBoxHandle, EM_GETFIRSTVISIBLELINE, 0, ByVal 0&)
SendMessage TextBoxHandle, EM_LINESCROLL, 0, ByVal CLng((LineNumber - 1) - LineIndex)
Else
ERR.Raise 380
End If
End If
End Sub
Public Sub ScrollToCaret()
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_SCROLLCARET, 0, ByVal 0&
End Sub
Public Function CharFromPos(ByVal X As Single, ByVal Y As Single) As Long
Dim p As POINTAPI
p.X = UserControl.ScaleX(X, vbContainerPosition, vbPixels)
p.Y = UserControl.ScaleY(Y, vbContainerPosition, vbPixels)
If TextBoxHandle <> 0 Then CharFromPos = CIntToUInt(LoWord(SendMessage(TextBoxHandle, EM_CHARFROMPOS, 0, ByVal MakeDWord(p.X, p.Y))))
End Function
Public Function GetLineFromChar(ByVal CharIndex As Long) As Long
If CharIndex < -1 Then ERR.Raise 380
If TextBoxHandle <> 0 Then GetLineFromChar = SendMessage(TextBoxHandle, EM_LINEFROMCHAR, CharIndex, ByVal 0&) + 1
End Function
Public Function ShowBalloonTip(ByVal Text As String, Optional ByVal Title As String, Optional ByVal Icon As TxtIconConstants) As Boolean
If TextBoxHandle <> 0 And ComCtlsSupportLevel() >= 1 Then
Dim EDITBT As EDITBALLOONTIP
With EDITBT
.cbStruct = LenB(EDITBT)
.pszText = StrPtr(Text)
.pszTitle = StrPtr(Title)
Select Case Icon
Case TxtIconNone, TxtIconInfo, TxtIconWarning, TxtIconError
.iIcon = Icon
Case Else
ERR.Raise 380
End Select
If GetFocus() <> TextBoxHandle Then SetFocusAPI UserControl.hwnd
ShowBalloonTip = CBool(SendMessage(TextBoxHandle, EM_SHOWBALLOONTIP, 0, ByVal VarPtr(EDITBT)) <> 0)
End With
End If
End Function
Public Function HideBalloonTip() As Boolean
If TextBoxHandle <> 0 And ComCtlsSupportLevel() >= 1 Then HideBalloonTip = CBool(SendMessage(TextBoxHandle, EM_HIDEBALLOONTIP, 0, ByVal 0&) <> 0)
End Function
Public Property Get LeftMargin() As Single
If TextBoxHandle <> 0 Then LeftMargin = UserControl.ScaleX(LoWord(SendMessage(TextBoxHandle, EM_GETMARGINS, 0, ByVal 0&)), vbPixels, vbContainerSize)
End Property
Public Property Let LeftMargin(ByVal Value As Single)
If Value = EC_USEFONTINFO Or Value = -1 Then
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_SETMARGINS, EC_LEFTMARGIN, ByVal EC_USEFONTINFO
Else
If Value < 0 Then ERR.Raise 380
Dim IntValue As Integer
IntValue = CInt(UserControl.ScaleX(Value, vbContainerSize, vbPixels))
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_SETMARGINS, EC_LEFTMARGIN, ByVal MakeDWord(IntValue, 0)
End If
End Property
Public Property Get RightMargin() As Single
If TextBoxHandle <> 0 Then RightMargin = UserControl.ScaleX(HiWord(SendMessage(TextBoxHandle, EM_GETMARGINS, 0, ByVal 0&)), vbPixels, vbContainerSize)
End Property
Public Property Let RightMargin(ByVal Value As Single)
If Value = EC_USEFONTINFO Or Value = -1 Then
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_SETMARGINS, EC_RIGHTMARGIN, ByVal EC_USEFONTINFO
Else
If Value < 0 Then ERR.Raise 380
Dim IntValue As Integer
IntValue = CInt(UserControl.ScaleX(Value, vbContainerSize, vbPixels))
If TextBoxHandle <> 0 Then SendMessage TextBoxHandle, EM_SETMARGINS, EC_RIGHTMARGIN, ByVal MakeDWord(0, IntValue)
End If
End Property
Public Sub ValidateNetAddress()
TextBoxNetAddressFormat = TxtNetAddressFormatNone
TextBoxNetAddressString = vbNullString
TextBoxNetAddressPortNumber = 0
TextBoxNetAddressPrefixLength = 0
If TextBoxHandle <> 0 And PropNetAddressValidator = True Then
If ComCtlsSupportLevel() >= 2 Then
Dim NCADDR As NC_ADDRESS, NETADDRINFO_UNSPECIFIED As NET_ADDRESS_INFO_UNSPECIFIED, ErrVal As Long
NCADDR.pAddrInfo = VarPtr(NETADDRINFO_UNSPECIFIED)
ErrVal = SendMessage(TextBoxHandle, NCM_GETADDRESS, 0, ByVal VarPtr(NCADDR))
Const ERROR_SUCCESS As Long = &H0, S_FALSE As Long = &H1, ERROR_INSUFFICIENT_BUFFER As Long = &H7A, ERROR_INVALID_PARAMETER As Long = &H57, E_INVALIDARG As Long = &H80070057
Select Case ErrVal
Case ERROR_SUCCESS
TextBoxNetAddressFormat = NETADDRINFO_UNSPECIFIED.Format
TextBoxNetAddressPortNumber = NCADDR.PortNumber
TextBoxNetAddressPrefixLength = NCADDR.PrefixLength
Select Case NETADDRINFO_UNSPECIFIED.Format
Case NET_ADDRESS_FORMAT_UNSPECIFIED
ERR.Raise Number:=380, Description:="The network address format is not provided."
Case NET_ADDRESS_DNS_NAME
Dim NETADDRINFO_DNSNAME As NET_ADDRESS_INFO_DNS_NAME
CopyMemory ByVal VarPtr(NETADDRINFO_DNSNAME), NETADDRINFO_UNSPECIFIED.data(0), LenB(NETADDRINFO_DNSNAME)
TextBoxNetAddressString = Left$(NETADDRINFO_DNSNAME.Address(), InStr(NETADDRINFO_DNSNAME.Address(), vbNullChar) - 1)
Case NET_ADDRESS_IPV4
Dim NETADDRINFO_IPV4 As NET_ADDRESS_INFO_IPV4
CopyMemory ByVal VarPtr(NETADDRINFO_IPV4), NETADDRINFO_UNSPECIFIED.data(0), LenB(NETADDRINFO_IPV4)
With NETADDRINFO_IPV4
TextBoxNetAddressString = HiByte(HiWord(.sin_addr)) & "." & LoByte(HiWord(.sin_addr)) & "." & HiByte(LoWord(.sin_addr)) & "." & LoByte(LoWord(.sin_addr))
End With
Case NET_ADDRESS_IPV6
Dim NETADDRINFO_IPV6 As NET_ADDRESS_INFO_IPV6, Buffer As String, Temp As String, i As Long
CopyMemory ByVal VarPtr(NETADDRINFO_IPV6), NETADDRINFO_UNSPECIFIED.data(0), LenB(NETADDRINFO_IPV6)
With NETADDRINFO_IPV6
For i = 1 To 8
Temp = Format(Hex(LoByte(.sin6_addr(i - 1))), "00") & Format(Hex(HiByte(.sin6_addr(i - 1))), "00")
Do While Left$(Temp, 1) = "0"
If Len(Temp) = 1 Then Exit Do
Temp = Mid$(Temp, 2)
Loop
Buffer = Buffer & Temp & ":"
Next i
TextBoxNetAddressString = Mid$(Buffer, 1, Len(Buffer) - 1) ' Uncompressed IPv6 format
End With
Case Else
ERR.Raise Number:=380, Description:="The network address format is unspecified."
End Select
Case S_FALSE
ERR.Raise Number:=380, Description:="There is no network address string to validate."
Case ERROR_INSUFFICIENT_BUFFER
ERR.Raise Number:=ERROR_INSUFFICIENT_BUFFER, Description:="The out buffer is too small to hold the parsed network address."
Case ERROR_INVALID_PARAMETER
ERR.Raise Number:=ERROR_INVALID_PARAMETER, Description:="The network address string is not of any type specified."
Case E_INVALIDARG
ERR.Raise Number:=E_INVALIDARG, Description:="The network address string is invalid."
Case Else
ERR.Raise Number:=ErrVal, Description:="Unexpected error."
End Select
Else
ERR.Raise Number:=5, Description:="To use this functionality, you must provide a manifest specifying comctl32.dll version 6.1 or higher."
End If
Else
ERR.Raise Number:=5, Description:="Procedure call can't be carried out as property NetAddressValidator is False."
End If
End Sub
Public Sub ShowNetAddressErrorTip()
If TextBoxHandle <> 0 And PropNetAddressValidator = True And ComCtlsSupportLevel() >= 2 Then
If GetFocus() <> TextBoxHandle Then SetFocusAPI UserControl.hwnd
SendMessage TextBoxHandle, NCM_DISPLAYERRORTIP, 0, ByVal 0&
End If
End Sub
Public Property Get NetAddressFormat() As TxtNetAddressFormatConstants
NetAddressFormat = TextBoxNetAddressFormat
End Property
Public Property Get NetAddressString() As String
NetAddressString = TextBoxNetAddressString
End Property
Public Property Get NetAddressPortNumber() As Integer
NetAddressPortNumber = TextBoxNetAddressPortNumber
End Property
Public Property Get NetAddressPrefixLength() As Byte
NetAddressPrefixLength = TextBoxNetAddressPrefixLength
End Property
Private Function ISubclass_Message(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal dwRefData As Long) As Long
Select Case dwRefData
Case 1
ISubclass_Message = WindowProcControl(hwnd, wMsg, wParam, lParam)
Case 2
ISubclass_Message = WindowProcUserControl(hwnd, wMsg, wParam, lParam)
End Select
End Function
Private Function WindowProcControl(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case wMsg
Case WM_SETFOCUS
If wParam <> UserControl.hwnd Then SetFocusAPI UserControl.hwnd: Exit Function
Call ActivateIPAO(Me)
Case WM_KILLFOCUS
Call DeActivateIPAO
Case WM_SETCURSOR
If LoWord(lParam) = HTCLIENT Then
If PropOLEDragMode = vbOLEDragAutomatic Then
Dim P3 As POINTAPI
Dim CharPos As Long, CaretPos As Long
Dim SelStart As Long, SelEnd As Long
GetCursorPos P3
ScreenToClient TextBoxHandle, P3
CharPos = CIntToUInt(LoWord(SendMessage(TextBoxHandle, EM_CHARFROMPOS, 0, ByVal MakeDWord(P3.X, P3.Y))))
CaretPos = SendMessage(TextBoxHandle, EM_POSFROMCHAR, CharPos, ByVal 0&)
SendMessage TextBoxHandle, EM_GETSEL, VarPtr(SelStart), ByVal VarPtr(SelEnd)
TextBoxAutoDragInSel = CBool(CharPos >= SelStart And CharPos <= SelEnd And CaretPos > -1 And (SelEnd - SelStart) > 0)
If TextBoxAutoDragInSel = True Then
SetCursor LoadCursor(0, MousePointerID(vbArrow))
WindowProcControl = 1
Exit Function
End If
Else
TextBoxAutoDragInSel = False
End If
If MousePointerID(PropMousePointer) <> 0 Then
SetCursor LoadCursor(0, MousePointerID(PropMousePointer))
WindowProcControl = 1
Exit Function
ElseIf PropMousePointer = 99 Then
If Not PropMouseIcon Is Nothing Then
SetCursor PropMouseIcon.Handle
WindowProcControl = 1
Exit Function
End If
End If
End If
Case WM_MOUSEACTIVATE
Static InProc As Boolean
If TextBoxTopDesignMode = False And GetFocus() <> TextBoxHandle Then
If InProc = True Or LoWord(lParam) = HTBORDER Then WindowProcControl = MA_ACTIVATEANDEAT: Exit Function
Select Case HiWord(lParam)
Case WM_LBUTTONDOWN
On Error Resume Next
With UserControl
If .Extender.CausesValidation = True Then
InProc = True
Call ComCtlsTopParentValidateControls(Me)
InProc = False
If ERR.Number = 380 Then
WindowProcControl = MA_ACTIVATEANDEAT
Else
SetFocusAPI .hwnd
WindowProcControl = MA_NOACTIVATE
End If
Else
SetFocusAPI .hwnd
WindowProcControl = MA_NOACTIVATE
End If
End With
On Error GoTo 0
Exit Function
End Select
End If
Case WM_KEYDOWN, WM_KEYUP, WM_SYSKEYDOWN, WM_SYSKEYUP
Dim KeyCode As Integer
KeyCode = wParam And &HFF&
If wMsg = WM_KEYDOWN Or wMsg = WM_KEYUP Then
If wMsg = WM_KEYDOWN Then
RaiseEvent KeyDown(KeyCode, GetShiftStateFromMsg())
ElseIf wMsg = WM_KEYUP Then
RaiseEvent KeyUp(KeyCode, GetShiftStateFromMsg())
End If
If KeyCode = vbKeyInsert And PropAllowOverType = True Then
If wMsg = WM_KEYDOWN Then PropOverTypeMode = Not PropOverTypeMode
End If
TextBoxCharCodeCache = ComCtlsPeekCharCode(hwnd)
ElseIf wMsg = WM_SYSKEYDOWN Then
RaiseEvent KeyDown(KeyCode, GetShiftStateFromMsg())
ElseIf wMsg = WM_SYSKEYUP Then
RaiseEvent KeyUp(KeyCode, GetShiftStateFromMsg())
End If
wParam = KeyCode
Case WM_CHAR
Dim KeyChar As Integer
If TextBoxCharCodeCache <> 0 Then
KeyChar = CUIntToInt(TextBoxCharCodeCache And &HFFFF&)
TextBoxCharCodeCache = 0
Else
KeyChar = CUIntToInt(wParam And &HFFFF&)
End If
RaiseEvent KeyPress(KeyChar)
If (wParam And &HFFFF&) <> 0 And KeyChar = 0 Then
Exit Function
Else
wParam = CIntToUInt(KeyChar)
End If
If PropAllowOverType = True And PropOverTypeMode = True Then
If wParam >= 32 Then ' 0 to 31 are non-printable
If Me.SelLength = 0 Then
Dim FirstCharPos As Long, Length As Long
FirstCharPos = SendMessage(TextBoxHandle, EM_LINEINDEX, -1, ByVal 0&)
If FirstCharPos > -1 Then
Length = SendMessage(TextBoxHandle, EM_LINELENGTH, FirstCharPos, ByVal 0&)
If Length > 0 Then
If Me.SelStart < (FirstCharPos + Length) Then
Me.SelLength = 1
Me.SelText = vbNullString
End If
End If
End If
End If
End If
End If
Case WM_UNICHAR
If wParam = UNICODE_NOCHAR Then WindowProcControl = 1 Else SendMessage hwnd, WM_CHAR, wParam, ByVal lParam
Exit Function
Case WM_INPUTLANGCHANGE
Call ComCtlsSetIMEMode(hwnd, TextBoxIMCHandle, PropIMEMode)
Case WM_IME_SETCONTEXT
If wParam <> 0 Then Call ComCtlsSetIMEMode(hwnd, TextBoxIMCHandle, PropIMEMode)
Case WM_IME_CHAR
SendMessage hwnd, WM_CHAR, wParam, ByVal lParam
Exit Function
Case WM_LBUTTONDOWN
If PropOLEDragMode = vbOLEDragAutomatic And TextBoxAutoDragInSel = True Then
Dim P1 As POINTAPI
P1.X = Get_X_lParam(lParam)
P1.Y = Get_Y_lParam(lParam)
ClientToScreen TextBoxHandle, P1
If DragDetect(TextBoxHandle, CUIntToInt(P1.X And &HFFFF&), CUIntToInt(P1.Y And &HFFFF&)) <> 0 Then
TextBoxIsClick = False
Me.OLEDrag
End If
Exit Function
End If
Case WM_VSCROLL, WM_HSCROLL
' The notification codes EN_HSCROLL and EN_VSCROLL are not sent when clicking the scroll bar thumb itself.
If LoWord(wParam) = SB_THUMBTRACK Then RaiseEvent Scroll
Case WM_CONTEXTMENU
If wParam = TextBoxHandle Then
Dim P2 As POINTAPI, Handled As Boolean
P2.X = Get_X_lParam(lParam)
P2.Y = Get_Y_lParam(lParam)
If P2.X > 0 And P2.Y > 0 Then
ScreenToClient TextBoxHandle, P2
RaiseEvent ContextMenu(Handled, UserControl.ScaleX(P2.X, vbPixels, vbContainerPosition), UserControl.ScaleY(P2.Y, vbPixels, vbContainerPosition))
ElseIf P2.X = -1 And P2.Y = -1 Then
' If the user types SHIFT + F10 then the X and Y coordinates are -1.
RaiseEvent ContextMenu(Handled, -1, -1)
End If
If Handled = True Then Exit Function
End If
Case WM_SETTEXT
If TextBoxChangeFrozen = False And PropMultiLine = True Then
' According to MSDN:
' The EN_CHANGE notification code is not sent when the ES_MULTILINE style is used and the text is sent through WM_SETTEXT.
Dim Buffer(0 To 1) As String
Buffer(0) = String(SendMessage(hwnd, WM_GETTEXTLENGTH, 0, ByVal 0&), vbNullChar)
SendMessage hwnd, WM_GETTEXT, Len(Buffer(0)) + 1, ByVal StrPtr(Buffer(0))
If lParam <> 0 Then
Buffer(1) = String(lstrlen(lParam), vbNullChar)
CopyMemory ByVal StrPtr(Buffer(1)), ByVal lParam, LenB(Buffer(1))
End If
If Buffer(0) <> Buffer(1) Then
WindowProcControl = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
UserControl.PropertyChanged "Text"
On Error Resume Next
UserControl.Extender.DataChanged = True
On Error GoTo 0
RaiseEvent Change
Exit Function
End If
End If
Case WM_PASTE
If PropAllowOnlyNumbers = True Then
If ComCtlsSupportLevel() <= 1 Then
Dim Text As String
Text = GetClipboardText()
If Not Text = vbNullString Then
Dim i As Long, InvalidText As Boolean
For i = 1 To Len(Text)
If InStr("0123456789", Mid$(Text, i, 1)) = 0 Then
InvalidText = True
Exit For
End If
Next i
If InvalidText = True Then
VBA.Interaction.Beep
Exit Function
End If
End If
End If
End If
End Select
WindowProcControl = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
Select Case wMsg
Case WM_LBUTTONDBLCLK, WM_MBUTTONDBLCLK, WM_RBUTTONDBLCLK
RaiseEvent DblClick
Case WM_LBUTTONDOWN, WM_MBUTTONDOWN, WM_RBUTTONDOWN, WM_MOUSEMOVE, WM_LBUTTONUP, WM_MBUTTONUP, WM_RBUTTONUP
Dim X As Single
Dim Y As Single
X = UserControl.ScaleX(Get_X_lParam(lParam), vbPixels, vbTwips)
Y = UserControl.ScaleY(Get_Y_lParam(lParam), vbPixels, vbTwips)
Select Case wMsg
Case WM_LBUTTONDOWN
RaiseEvent MouseDown(vbLeftButton, GetShiftStateFromParam(wParam), X, Y)
TextBoxIsClick = True
Case WM_MBUTTONDOWN
RaiseEvent MouseDown(vbMiddleButton, GetShiftStateFromParam(wParam), X, Y)
TextBoxIsClick = True
Case WM_RBUTTONDOWN
RaiseEvent MouseDown(vbRightButton, GetShiftStateFromParam(wParam), X, Y)
TextBoxIsClick = True
Case WM_MOUSEMOVE
If TextBoxMouseOver = False And PropMouseTrack = True Then
TextBoxMouseOver = True
RaiseEvent MouseEnter
Call ComCtlsRequestMouseLeave(hwnd)
End If
RaiseEvent MouseMove(GetMouseStateFromParam(wParam), GetShiftStateFromParam(wParam), X, Y)
Case WM_LBUTTONUP, WM_MBUTTONUP, WM_RBUTTONUP
Select Case wMsg
Case WM_LBUTTONUP
RaiseEvent MouseUp(vbLeftButton, GetShiftStateFromParam(wParam), X, Y)
Case WM_MBUTTONUP
RaiseEvent MouseUp(vbMiddleButton, GetShiftStateFromParam(wParam), X, Y)
Case WM_RBUTTONUP
RaiseEvent MouseUp(vbRightButton, GetShiftStateFromParam(wParam), X, Y)
End Select
If TextBoxIsClick = True Then
TextBoxIsClick = False
If (X >= 0 And X <= UserControl.Width) And (Y >= 0 And Y <= UserControl.Height) Then RaiseEvent Click
End If
End Select
Case WM_MOUSELEAVE
If TextBoxMouseOver = True Then
TextBoxMouseOver = False
RaiseEvent MouseLeave
End If
End Select
End Function
Private Function WindowProcUserControl(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case wMsg
Case WM_COMMAND
Select Case HiWord(wParam)
Case EN_CHANGE
If TextBoxChangeFrozen = False Then
UserControl.PropertyChanged "Text"
On Error Resume Next
UserControl.Extender.DataChanged = True
On Error GoTo 0
RaiseEvent Change
End If
Case EN_MAXTEXT
RaiseEvent MaxText
Case EN_HSCROLL, EN_VSCROLL
' This notification code is also sent when a keyboard event causes a change in the view area.
RaiseEvent Scroll
End Select
End Select
WindowProcUserControl = ComCtlsDefaultProc(hwnd, wMsg, wParam, lParam)
If wMsg = WM_SETFOCUS Then SetFocusAPI TextBoxHandle
End Function

复制代码

PPTextBoxWText.pag

Option Explicit
Private FreezeChanged As Boolean
Private TextObject As Object
Private WithEvents TextObjectEvents As TextBoxW
Private Sub PropertyPage_Initialize()
Call ComCtlsShowAllUIStates(PropertyPage.hwnd)
On Error Resume Next
ERR.Raise 5
Set TextObject = PropertyPage.Controls.Add(ERR.Source & ".TextBoxW", "TextObject", Me)
On Error GoTo 0
If Not TextObject Is Nothing Then
Set TextObjectEvents = TextObject
TextObject.Left = 120
TextObject.Top = 120
TextObject.Width = 5655
TextObject.Height = 315
TextObject.Visible = True
TextObject.ZOrder vbBringToFront
End If
End Sub
Private Sub PropertyPage_ApplyChanges()
With PropertyPage.SelectedControls(0)
If Not TextObject Is Nothing Then .Text = TextObject.Text
End With
Call PropertyPage_SelectionChanged
End Sub
Private Sub PropertyPage_SelectionChanged()
FreezeChanged = True
With PropertyPage.SelectedControls(0)
If Not TextObject Is Nothing Then
If .MultiLine = True Then
TextObject.Height = 3195
TextObject.ScrollBars = vbBoth
Else
TextObject.Height = 315
TextObject.ScrollBars = vbSBNone
End If
TextObject.MultiLine = .MultiLine
TextObject.Text = .Text
End If
End With
FreezeChanged = False
End Sub
Private Sub PropertyPage_EditProperty(PropertyName As String)
If PropertyName = "Text" Then TextObject.SetFocus
End Sub
Private Sub TextObjectEvents_Change()
If FreezeChanged = True Then Exit Sub
PropertyPage.Changed = True
End Sub
Private Sub TextObjectEvents_KeyPress(KeyChar As Integer)
If KeyChar = vbKeyReturn Then KeyChar = AscW(vbLf)
End Sub

复制代码

所需附件：

FrmAbout.frx (166.71 KB, 下载次数: 0)

FrmMain.frx (109.86 KB, 下载次数: 0)

FrmMessage.frx (84.7 KB, 下载次数: 0)

FrmMusic.frx (82.01 KB, 下载次数: 0)

SButton.ctx (786 Bytes, 下载次数: 0)

SSwitch.ctx (786 Bytes, 下载次数: 0)

SundyNotes.vbw (1.31 KB, 下载次数: 0)

TextBoxW.ctx (856 Bytes, 下载次数: 0)

账号		自动登录	找回密码
密码			立即注册→加入我们